json: new special var *print-json-type*.

This variable controls whether we emit the "__type" key
for structures.

* lib.c (out_json_rec): React to the new variable, via
the flag in the json_opts structure: include the "__type" key
only if it is requested.
(out_json, put_json): Initialize the type flag in the josn_opts
according to the *print-json-type* dynamic variable.

* stream.c (print_json_type_s): New symbol variable.
(stream_init): print_json_type_s initialized, and
corresponding special variable registered, with intial value t.

* stream.h (struct json_opts): New bitfield member, type.
(print_json_type_s): Declared.

* txr.1: Documented.

4 files changed, 45 insertions, 11 deletions

diff --git a/lib.c b/lib.c
index 3937fcc4..009e2596 100644
--- a/lib.c
+++ b/lib.c
@@ -15088,12 +15088,17 @@ static void out_json_rec(val obj, val out, struct json_opts jo,
       val iter;
       val save_indent;
       int force_br = 0;
+      int first = 1;
 
       if (!jo.flat && jo.fmt == json_fmt_standard) {
         put_string(lit("{\n"), out);
         save_indent = inc_indent_abs(out, two);
-        put_string(lit("\"__type\" : "), out);
-        out_json_sym(ty, out, ctx);
+
+        if (jo.type) {
+          put_string(lit("\"__type\" : "), out);
+          out_json_sym(ty, out, ctx);
+          first = 0;
+        }
 
         for (iter = sl; iter; iter = cdr(iter)) {
           val slsym = car(iter);
@@ -15101,7 +15106,9 @@ static void out_json_rec(val obj, val out, struct json_opts jo,
           if (static_slot_p(ty, slsym))
             continue;
 
-          put_string(lit(",\n"), out);
+          if (!first)
+            put_string(lit(",\n"), out);
+          first = 0;
           out_json_sym(slsym, out, ctx);
           put_string(lit(" : "), out);
           out_json_rec(slot(obj, slsym), out, jo, ctx);
@@ -15110,8 +15117,12 @@ static void out_json_rec(val obj, val out, struct json_opts jo,
       } else {
         put_char(chr('{'), out);
         save_indent = inc_indent(out, zero);
-        put_string(lit("\"__type\":"), out);
-        out_json_sym(ty, out, ctx);
+
+        if (jo.type) {
+          put_string(lit("\"__type\":"), out);
+          out_json_sym(ty, out, ctx);
+          first = 0;
+        }
 
         for (iter = sl; iter; iter = cdr(iter)) {
           val slsym = car(iter);
@@ -15119,7 +15130,9 @@ static void out_json_rec(val obj, val out, struct json_opts jo,
           if (static_slot_p(ty, slsym))
             continue;
 
-          put_string(lit(","), out);
+          if (!first)
+            put_string(lit(","), out);
+          first = 0;
           if (width_check(out, nil))
             force_br = 1;
           out_json_sym(slsym, out, ctx);
@@ -15158,9 +15171,11 @@ static void out_json(val op, val obj, val out, struct strm_ctx *ctx)
   val save_mode = test_set_indent_mode(out, num_fast(indent_off),
                                        num_fast(indent_data));
   val jfsym = cdr(lookup_var(nil, print_json_format_s));
+  val type = cdr(lookup_var(nil, print_json_type_s));
   struct json_opts jo = {
     if3(jfsym == standard_k, json_fmt_standard, json_fmt_default),
-    0
+    0,
+    type != nil
   };
   if (op == sys_qquote_s)
     put_char(chr('^'), out);
@@ -15861,9 +15876,11 @@ val put_json(val obj, val stream_in, val flat)
                                        num_fast(indent_data)));
   val isave = get_indent(stream);
   val jfsym = cdr(lookup_var(nil, print_json_format_s));
+  val type = cdr(lookup_var(nil, print_json_type_s));
   struct json_opts jo = {
     if3(jfsym == standard_k, json_fmt_standard, json_fmt_default),
-    flat != nil
+    flat != nil,
+    type != nil
   };
   uw_simple_catch_begin;
   out_json_rec(obj, stream, jo, 0);
diff --git a/stream.c b/stream.c
index 7114a123..58d0804f 100644
--- a/stream.c
+++ b/stream.c
@@ -95,7 +95,7 @@ val get_error_s, get_error_str_s, clear_error_s, get_fd_s;
 
 val print_flo_precision_s, print_flo_digits_s, print_flo_format_s;
 val pprint_flo_format_s, print_base_s, print_circle_s;
-val print_json_format_s;
+val print_json_format_s, print_json_type_s;
 
 val from_start_k, from_current_k, from_end_k;
 val real_time_k, name_k, addr_k, fd_k, byte_oriented_k;
@@ -5587,6 +5587,7 @@ void stream_init(void)
           num_fast(10));
   reg_var(print_circle_s = intern(lit("*print-circle*"), user_package), nil);
   reg_var(print_json_format_s = intern(lit("*print-json-format*"), user_package), nil);
+  reg_var(print_json_type_s = intern(lit("*print-json-type*"), user_package), t);
 
 #if HAVE_ISATTY
   if (isatty(fileno(stdin)) == 1) {
diff --git a/stream.h b/stream.h
index a334a8ff..06cf5cec 100644
--- a/stream.h
+++ b/stream.h
@@ -142,6 +142,7 @@ enum json_fmt {
 struct json_opts {
   enum json_fmt fmt : 4;
   unsigned flat : 1;
+  unsigned type : 1;
 };
 
 loc lookup_var_l(val env, val sym);
@@ -162,7 +163,7 @@ extern val get_error_s, get_error_str_s, clear_error_s, get_fd_s;
 
 extern val print_flo_precision_s, print_flo_digits_s, print_flo_format_s;
 extern val pprint_flo_format_s, print_base_s, print_circle_s;
-extern val print_json_format_s;
+extern val print_json_format_s, print_json_type_s;
 
 #if HAVE_SOCKETS
 extern val socket_error_s;
diff --git a/txr.1 b/txr.1
index 5b8a6b2c..942d79c3 100644
--- a/txr.1
+++ b/txr.1
@@ -84197,9 +84197,13 @@ object notation. The keys of the objects are the names of the
 symbols of the object type's non-static slots, appearing as a
 string. The values are the values of the slots. They must be JSON-conforming
 objects.
-The first entry of the object is a key named
+If the special variable
+.code *print-json-type*
+is true, the object includes a key named
 .str __type
 whose value is the structure type symbol, appearing as a string.
+When present, this key occurs first in the printed representation,
+before any other keys.
 Both the slot symbols and the type symbol may appear with a package
 qualifier, depending on the relationship of the symbols to the current
 package, according to similar rules as if the symbol were printed
@@ -84651,6 +84655,17 @@ and elements appear on the same line, subject to automatic
 breaking and indentation, similar to the way Lisp nested
 list structure is printed.
 
+.coNP Special Variable @ *print-json-type*
+.desc
+The
+.code *print-json-type*
+variable, whose initial value is
+.codn t ,
+controls whether the
+.str __type
+field is included when a structure object is
+printed as JSON.
+
 .coNP Variable @ *read-bad-json*
 .desc
 This dynamic variable, initialized to a value of