Oh, yeah, I'm digging me that merge tracking. Trunkward, ho!

svn: r11717

collects/drscheme/private/debug.ss

@@ -997,10 +997,11 @@ profile todo:
       (super-new)))
   
   (define test-covered-style-delta (make-object style-delta%))
-  (send test-covered-style-delta set-delta-foreground "forest green")
-  
   (define test-not-covered-style-delta (make-object style-delta%))
-  (send test-not-covered-style-delta set-delta-foreground "firebrick")
+  
+  ;; test colors chosen to try to be color-blindness friendly
+  (send test-covered-style-delta set-delta-foreground "forest green")
+  (send test-not-covered-style-delta set-delta-foreground "maroon")
   
   (define erase-test-coverage-style-delta (make-object style-delta% 'change-normal-color))
   

collects/handin-client/client-gui.ss

@@ -256,9 +256,9 @@
     (define interface-widgets
       (list ok username passwd assignment retrieve?))
     (define (disable-interface)
-      (for ([x interface-widgets]) (send x enable #f)))
+      (for ([x (in-list interface-widgets)]) (send x enable #f)))
     (define (enable-interface)
-      (for ([x interface-widgets]) (send x enable #t) ))
+      (for ([x (in-list interface-widgets)]) (send x enable #t) ))
     (define (done-interface)
       (send cancel set-label "Close")
       (send cancel focus))
@@ -309,7 +309,7 @@
                    (handin-disconnect h)
                    (error 'handin "there are no active assignments"))
                  (set! connection h)
-                 (for ([assign l]) (send assignment append assign))
+                 (for ([assign (in-list l)]) (send assignment append assign))
                  (send assignment enable #t)
                  (set! ok-can-enable? #t)
                  (activate-ok)
@@ -575,8 +575,8 @@
              "Password Error"
              (format "The \"~a\" and \"~a\" passwords are not the same." l1 l2))
             (k (void))))
-        (for ([t (if new? add-user-fields change-user-fields)]
+        (for ([t (in-list (if new? add-user-fields change-user-fields))]
-              [f (or user-fields '())])
+              [f (in-list (or user-fields '()))])
           (check-length t 100 f k))
         (send tabs enable #f)
         (parameterize ([current-custodian comm-cust])
@@ -716,7 +716,7 @@
          [stream (make-object editor-stream-out% base)])
     (write-editor-version stream base)
     (write-editor-global-header stream)
-    (for ([ed editors]) (send ed write-to-file stream))
+    (for ([ed (in-list editors)]) (send ed write-to-file stream))
     (write-editor-global-footer stream)
     (send base get-bytes)))
 

collects/handin-client/client.ss

@@ -19,7 +19,7 @@
   (error (apply format fmt args)))
 
 (define (write+flush port . xs)
-  (for ([x xs]) (write x port) (newline port))
+  (for ([x (in-list xs)]) (write x port) (newline port))
   (flush-output port))
 
 (define (close-handin-ports h)

collects/handin-client/handin-multi.ss

@@ -27,7 +27,7 @@
   (let/ec return
     (parameterize ([current-output-port (open-output-bytes)])
       (printf "~a\n" magic)
-      (for ([file files])
+      (for ([file (in-list files)])
         (let ([size (and (file-exists? file) (file-size file))])
           (unless size (return #f))
           (let ([buf (with-input-from-file file
@@ -71,7 +71,7 @@
                                     (string? (car x)) (bytes? (cadr x))))
                              files))
           (error* "Error in retrieved content: bad format"))
-        (for ([file files])
+        (for ([file (in-list files)])
           (let ([file (car file)] [buf (cadr file)])
             (when (write? file)
               (with-output-to-file file

collects/handin-client/updater.ss

@@ -17,7 +17,7 @@
 (define (update!)
   (let* ([in   (file->inport package-filename)]
          [outf (make-temporary-file "tmp~a.plt")]
-         [out  (open-output-file outf 'binary 'truncate)])
+         [out  (open-output-file outf #:mode 'binary #:exists 'truncate)])
     (dynamic-wind
       void
       (lambda () (copy-port in out))

collects/handin-server/checker.ss

@@ -191,7 +191,7 @@
 ;; This code will hack textualization of text boxes
 
 (define (insert-to-editor editor . xs)
-  (for ([x xs])
+  (for ([x (in-list xs)])
     (send editor insert (if (string? x) x (make-object editor-snip% x)))))
 
 ;; support for "text-box%"
@@ -282,7 +282,7 @@
                                 '(ok-cancel caution)))))
         (error* "Aborting...")))
     ;; This will create copies of the original files
-    ;; (for ([file files])
+    ;; (for ([file (in-list files)])
     ;;   (with-output-to-file (car file)
     ;;     (lambda () (display (cadr file)) (flush-output))))
     (let* ([pfx-len  (string-length markup-prefix)]
@@ -298,7 +298,7 @@
         (display ===)
         (newline))
       (parameterize ([current-output-port (open-output-bytes)])
-        (for ([file files])
+        (for ([file (in-list files)])
           (sep (car file))
           (parameterize ([current-input-port (open-input-bytes (cadr file))]
                          [current-processed-file (car file)])
@@ -389,7 +389,7 @@
             [user-post      (id 'user-post)]
             [(body ...) (syntax-case #'(body ...) ()
                           [() #'(void)] [_ #'(body ...)])])
-         (for ([x keyvals])
+         (for ([x (in-list keyvals)])
            (unless (memq (car x) got)
              (raise-syntax-error #f "unknown keyword" stx (cadr x))))
          #'(begin
@@ -470,7 +470,7 @@
                      (set-run-status "creating text file")
                      (with-output-to-file text-file #:exists 'truncate
                        (lambda ()
-                         (for ([user users])
+                         (for ([user (in-list users)])
                            (prefix-line (user-substs user student-line)))
                          (for-each prefix-line/substs extra-lines)
                          (for-each prefix-line/substs

collects/handin-server/main.ss

@@ -24,7 +24,7 @@
   (error (apply format fmt args)))
 
 (define (write+flush port . xs)
-  (for ([x xs]) (write x port) (newline port))
+  (for ([x (in-list xs)]) (write x port) (newline port))
   (flush-output port))
 
 (define-struct alist (name [l #:mutable]))
@@ -87,7 +87,7 @@
       ;; SUCCESS, or things that are newer in the main submission
       ;; directory are kept (but subdirs in SUCCESS will are copied as
       ;; is))
-      (for ([f (directory-list dir)])
+      (for ([f (in-list (directory-list dir))])
         (define dir/f (build-path dir f))
         (cond [(not (or (file-exists? f) (directory-exists? f)))
                ;; f is in dir but not in the working directory
@@ -116,10 +116,10 @@
 
 (define (cleanup-all-submissions)
   (log-line "Cleaning up all submission directories")
-  (for ([pset (get-conf 'all-dirs)]
+  (for ([pset (in-list (get-conf 'all-dirs))]
         #:when (directory-exists? pset)) ; just in case
     (parameterize ([current-directory pset])
-      (for ([sub (directory-list)]
+      (for ([sub (in-list (directory-list))]
             #:when (directory-exists? sub)) ; filter non-dirs
         (cleanup-submission sub)))))
 
@@ -370,7 +370,7 @@
     (error* "the username \"checker.ss\" is reserved"))
   (when (get-user-data username)
     (error* "username already exists: `~a'" username))
-  (for ([str extra-fields]
+  (for ([str (in-list extra-fields)]
         [info (get-conf 'extra-fields)])
     (check-field str (cadr info) (car info) (caddr info)))
   (wait-for-lock "+newuser+")
@@ -397,8 +397,8 @@
       (error* "changing information not allowed: ~a" username))
     (when (equal? new-data old-data)
       (error* "no fields changed: ~a" username))
-    (for ([str (cdr new-data)]
+    (for ([str (in-list (cdr new-data))]
-          [info (get-conf 'extra-fields)])
+          [info (in-list (get-conf 'extra-fields))])
       (check-field str (cadr info) (car info) (caddr info)))
     (log-line "change info for ~a ~s -> ~s" username old-data new-data)
     (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change

collects/handin-server/private/logger.ss

@@ -74,5 +74,6 @@
   (current-error-port
    (make-logger-port
     (and (get-conf 'log-output) (current-output-port))
-    (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))]
+    (cond [(get-conf 'log-file)
+           => (lambda (f) (open-output-file f #:exists 'append))]
           [else #f]))))

collects/scheme/private/class-internal.ss

@@ -30,7 +30,7 @@
              class?
              mixin
              interface interface?
-             object% object? externalizable<%>
+             object% object? externalizable<%> printable<%>
              object=?
              new make-object instantiate
              send send/apply send* class-field-accessor class-field-mutator with-method
@@ -2041,6 +2041,13 @@
 						   ;; Map object property to class:
 						   (append
 						    (list (cons prop:object c))
+                                                    (if (interface-extension? i printable<%>)
+                                                        (list (cons prop:custom-write
+                                                                    (lambda (obj port write?)
+                                                                      (if write?
+                                                                          (send obj custom-write port)
+                                                                          (send obj custom-display port)))))
+                                                        null)
 						    (if deserialize-id
 							(list
 							 (cons prop:serializable
@@ -3694,6 +3701,9 @@
   (define externalizable<%>
     (_interface () externalize internalize))
 
+  (define printable<%>
+    (_interface () custom-write custom-display))
+
   ;; Providing traced versions:
   (provide class-traced
            class*-traced
@@ -3735,7 +3745,7 @@
            class?
            mixin
 	   (rename-out [_interface interface]) interface?
-	   object% object? object=? externalizable<%>
+	   object% object? object=? externalizable<%> printable<%>
            new make-object instantiate
            get-field field-bound? field-names
 	   send send/apply send* class-field-accessor class-field-mutator with-method

collects/scribblings/reference/class.scrbl

@@ -1539,6 +1539,25 @@ The @scheme[externalizable<%>] interface includes only the
 @scheme[externalize] and @scheme[internalize] methods. See
 @scheme[define-serializable-class*] for more information.}
 
+@; ------------------------------------------------------------------------
+
+@section[#:tag "objectprinting"]{Object Printing}
+
+To customize the way that a class instance is printed by @scheme[write]
+or @scheme[display], implement the @scheme[printable<%>] interface.
+
+@defthing[printable<%> interface?]{
+
+The @scheme[printable<%>] interface includes only the
+@scheme[custom-write] and @scheme[custom-print] methods. Each accepts
+a single argument, which is the destination port to @scheme[write] or
+@scheme[display] the object.
+
+Calls to the @scheme[custom-write] or @scheme[custom-display] are like
+calls to a procedure attached to a structure type through the
+@scheme[prop:custom-write] property. In particular, recursive printing
+can trigger an escape from the call. See @scheme[prop:custom-write]
+for more information.}
 
 @; ------------------------------------------------------------------------
 

collects/scribblings/reference/eval-model.scrbl

@@ -651,9 +651,9 @@ escape-continuation aborts can cross continuation barriers.
 @section[#:tag "thread-model"]{Threads}
 
 Scheme supports multiple, pre-emptive @deftech{threads} of
-evaluation. In terms of the evaluation model, this means that each
+evaluation. Threads are created explicitly by functions such as @scheme[thread]. 
-step in evaluation actually consists of multiple concurrent
+In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent
-expressions, rather than a single expression. The expressions all
+expressions, up to one per thread, rather than a single expression. The expressions all
 share the same objects and top-level variables, so that they can
 communicate through shared state. Most evaluation steps involve a
 single step in a single expression, but certain synchronization

collects/tests/mzscheme/object.ss

@@ -1375,6 +1375,44 @@
 (let ([c% (class object% (define foo (lambda () 10)) (define/public (get) foo) (super-new))])
   (test 'foo object-name (send (new c%) get)))
 
+;; ----------------------------------------
+;; Implementing printable<%>
+
+(let ()
+  (define (check w-cycle? d-cycle?)
+    (define c% (class* object% (printable<%>) 
+                 (define/public (custom-write p)
+                   (if w-cycle?
+                       (write this p)
+                       (display "hi" p)))
+                 (define/public (custom-display p) 
+                   (if d-cycle?
+                       (display this p)
+                       (display "HI" p)))
+                 (super-new)))
+
+    (let ([p (open-output-bytes)])
+      (write (new c%) p)
+      (test (if w-cycle? #"#0=#0#" #"hi")
+            get-output-bytes p))
+    (let ([p (open-output-bytes)])
+      (display (new c%) p)
+      (test (if d-cycle? #"#0=#0#" #"HI")
+            get-output-bytes p))
+
+    (let ([p (open-output-bytes)])
+      (write (new (class c%
+                    (define/override (custom-write p)
+                      (write 777 p))
+                    (super-new)))
+             p)
+      (test #"777" get-output-bytes p)))
+
+  (check #f #f)
+  (check #t #f)
+  (check #f #t)
+  (check #t #t))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/mzscheme/src/port.c

@@ -30,6 +30,7 @@
    ports. */
 
 #include "schpriv.h"
+#include "schmach.h"
 #ifdef UNISTD_INCLUDE
 # include <unistd.h>
 #endif
@@ -6635,17 +6636,57 @@ scheme_make_null_output_port(int can_write_special)
 /*                         redirect output ports                          */
 /*========================================================================*/
 
+static Scheme_Object *redirect_write_bytes_k(void);
+
 static long
 redirect_write_bytes(Scheme_Output_Port *op,
 		     const char *str, long d, long len,
 		     int rarely_block, int enable_break)
 {
+  /* arbitrary nesting means we can overflow the stack */
+#ifdef DO_STACK_CHECK
+# include "mzstkchk.h"
+  {
+    Scheme_Thread *p = scheme_current_thread;
+    Scheme_Object *n;
+
+    p->ku.k.p1 = (void *)op;
+    p->ku.k.p2 = (void *)str;
+    p->ku.k.i1 = d;
+    p->ku.k.i2 = len;
+    p->ku.k.i3 = rarely_block;
+    p->ku.k.i4 = enable_break;
+
+    n = scheme_handle_stack_overflow(redirect_write_bytes_k);
+    return SCHEME_INT_VAL(n);
+  }
+#endif
+
   return scheme_put_byte_string("redirect-output",
 				(Scheme_Object *)op->port_data,
 				str, d, len,
 				rarely_block);
 }
 
+static Scheme_Object *redirect_write_bytes_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1;
+  const char *str = (const char *)p->ku.k.p2;
+  long d = p->ku.k.i1;
+  long len = p->ku.k.i2;
+  int rarely_block = p->ku.k.i3;
+  int enable_break = p->ku.k.i4;
+  long n;
+
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+
+  n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break);
+
+  return scheme_make_integer(n);
+}
+
 static void
 redirect_close_out (Scheme_Output_Port *port)
 {

src/mzscheme/src/print.c

@@ -112,7 +112,7 @@ static char *print_to_string(Scheme_Object *obj, long * volatile len, int write,
 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
                                 Scheme_Marshal_Tables *mt,
 				PrintParams *pp, int notdisplay);
-static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp);
+static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp);
 
 
 #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1)
@@ -394,7 +394,7 @@ scheme_internal_print(Scheme_Object *obj, Scheme_Object *port)
 }
 
 #ifdef DO_STACK_CHECK
-static int check_cycles(Scheme_Object *, Scheme_Hash_Table *ht, PrintParams *);
+static int check_cycles(Scheme_Object *, int, Scheme_Hash_Table *ht, PrintParams *);
 
 static Scheme_Object *check_cycle_k(void)
 {
@@ -407,12 +407,12 @@ static Scheme_Object *check_cycle_k(void)
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
 
-  return check_cycles(o, ht, pp)
+  return check_cycles(o, p->ku.k.i1, ht, pp)
     ? scheme_true : scheme_false;
 }
 #endif
 
-static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *pp)
+static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, PrintParams *pp)
 {
   Scheme_Type t;
 
@@ -424,6 +424,7 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
       scheme_current_thread->ku.k.p1 = (void *)obj;
       scheme_current_thread->ku.k.p2 = (void *)ht;
       scheme_current_thread->ku.k.p3 = (void *)pp;
+      scheme_current_thread->ku.k.i1 = for_write;
       return SCHEME_TRUEP(scheme_handle_stack_overflow(check_cycle_k));
     }
   }
@@ -451,27 +452,27 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     return 0;
 
   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
-    if (check_cycles(SCHEME_CAR(obj), ht, pp))
+    if (check_cycles(SCHEME_CAR(obj), for_write, ht, pp))
       return 1;
-    if (check_cycles(SCHEME_CDR(obj), ht, pp))
+    if (check_cycles(SCHEME_CDR(obj), for_write, ht, pp))
       return 1;
   } else if (SCHEME_BOXP(obj)) {
     /* got here => printable */
-    if (check_cycles(SCHEME_BOX_VAL(obj), ht, pp))
+    if (check_cycles(SCHEME_BOX_VAL(obj), for_write, ht, pp))
       return 1;
   } else if (SCHEME_VECTORP(obj)) {
     int i, len;
 
     len = SCHEME_VEC_SIZE(obj);
     for (i = 0; i < len; i++) {
-      if (check_cycles(SCHEME_VEC_ELS(obj)[i], ht, pp)) {
+      if (check_cycles(SCHEME_VEC_ELS(obj)[i], for_write, ht, pp)) {
 	return 1;
       }
     }
   } else if (SAME_TYPE(t, scheme_structure_type)
 	     || SAME_TYPE(t, scheme_proc_struct_type)) {
     if (scheme_is_writable_struct(obj)) {
-      if (check_cycles(writable_struct_subs(obj, pp), ht, pp))
+      if (check_cycles(writable_struct_subs(obj, for_write, pp), for_write, ht, pp))
 	return 1;
     } else {
       /* got here => printable */
@@ -479,7 +480,7 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
 
       while (i--) {
 	if (scheme_inspector_sees_part(obj, pp->inspector, i)) {
-	  if (check_cycles(((Scheme_Structure *)obj)->slots[i], ht, pp)) {
+	  if (check_cycles(((Scheme_Structure *)obj)->slots[i], for_write, ht, pp)) {
 	    return 1;
 	  }
 	}
@@ -497,9 +498,9 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     for (i = t->size; i--; ) {
       if (vals[i]) {
 	val = vals[i];
-	if (check_cycles(keys[i], ht, pp))
+	if (check_cycles(keys[i], for_write, ht, pp))
 	  return 1;
-	if (check_cycles(val, ht, pp))
+	if (check_cycles(val, for_write, ht, pp))
 	  return 1;
       }
     }
@@ -512,9 +513,9 @@ static int check_cycles(Scheme_Object *obj, Scheme_Hash_Table *ht, PrintParams *
     i = scheme_hash_tree_next(t, -1);
     while (i != -1) {
       scheme_hash_tree_index(t, i, &key, &val);
-      if (check_cycles(key, ht, pp))
+      if (check_cycles(key, for_write, ht, pp))
         return 1;
-      if (check_cycles(val, ht, pp))
+      if (check_cycles(val, for_write, ht, pp))
         return 1;
       i = scheme_hash_tree_next(t, i);
     }
@@ -614,7 +615,7 @@ END_XFORM_SKIP;
 #endif
 
 #ifdef DO_STACK_CHECK
-static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
+static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
 
 static Scheme_Object *setup_graph_k(void)
 {
@@ -623,19 +624,20 @@ static Scheme_Object *setup_graph_k(void)
   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p2;
   int *counter = (int *)p->ku.k.p3;
   PrintParams *pp = (PrintParams *)p->ku.k.p4;
+  int for_write = p->ku.k.i1;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
   p->ku.k.p4 = NULL;
 
-  setup_graph_table(o, ht, counter, pp);
+  setup_graph_table(o, for_write, ht, counter, pp);
 
   return scheme_false;
 }
 #endif
 
-static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
+static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht,
 			      int *counter, PrintParams *pp)
 {
   if (HAS_SUBSTRUCT(obj, ssQUICKp)) {
@@ -651,6 +653,7 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
 	scheme_current_thread->ku.k.p2 = (void *)ht;
 	scheme_current_thread->ku.k.p3 = (void *)counter;
 	scheme_current_thread->ku.k.p4 = (void *)pp;
+        scheme_current_thread->ku.k.i1 = for_write;
 	scheme_handle_stack_overflow(setup_graph_k);
 	return;
       }
@@ -674,29 +677,29 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
   SCHEME_USE_FUEL(1);
 
   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
-    setup_graph_table(SCHEME_CAR(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_CAR(obj), for_write, ht, counter, pp);
-    setup_graph_table(SCHEME_CDR(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_CDR(obj), for_write, ht, counter, pp);
   } else if ((!pp || pp->print_box) && SCHEME_BOXP(obj)) {
-    setup_graph_table(SCHEME_BOX_VAL(obj), ht, counter, pp);
+    setup_graph_table(SCHEME_BOX_VAL(obj), for_write, ht, counter, pp);
   } else if (SCHEME_VECTORP(obj)) {
     int i, len;
 
     len = SCHEME_VEC_SIZE(obj);
     for (i = 0; i < len; i++) {
-      setup_graph_table(SCHEME_VEC_ELS(obj)[i], ht, counter, pp);
+      setup_graph_table(SCHEME_VEC_ELS(obj)[i], for_write, ht, counter, pp);
     }
   } else if (pp && SCHEME_STRUCTP(obj)) { /* got here => printable */
     if (scheme_is_writable_struct(obj)) {
       if (pp->print_unreadable) {
-	obj = writable_struct_subs(obj, pp);
+	obj = writable_struct_subs(obj, for_write, pp);
-	setup_graph_table(obj, ht, counter, pp);
+	setup_graph_table(obj, for_write, ht, counter, pp);
       }
     } else {
       int i = SCHEME_STRUCT_NUM_SLOTS(obj);
 
       while (i--) {
 	if (scheme_inspector_sees_part(obj, pp->inspector, i))
-	  setup_graph_table(((Scheme_Structure *)obj)->slots[i], ht, counter, pp);
+	  setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp);
       }
     }
   } else if (pp && SCHEME_HASHTP(obj)) { /* got here => printable */
@@ -710,8 +713,8 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
     for (i = t->size; i--; ) {
       if (vals[i]) {
 	val = vals[i];
-	setup_graph_table(keys[i], ht, counter, pp);
+	setup_graph_table(keys[i], for_write, ht, counter, pp);
-	setup_graph_table(val, ht, counter, pp);
+	setup_graph_table(val, for_write, ht, counter, pp);
       }
     }
   } else if (SCHEME_HASHTRP(obj)) {
@@ -723,8 +726,8 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
     i = scheme_hash_tree_next(t, -1);
     while (i != -1) {
       scheme_hash_tree_index(t, i, &key, &val);
-      setup_graph_table(key, ht, counter, pp);
+      setup_graph_table(key, for_write, ht, counter, pp);
-      setup_graph_table(val, ht, counter, pp);
+      setup_graph_table(val, for_write, ht, counter, pp);
       i = scheme_hash_tree_next(t, i);
     }
   }
@@ -732,7 +735,7 @@ static void setup_graph_table(Scheme_Object *obj, Scheme_Hash_Table *ht,
 
 #define CACHE_HT_SIZE_LIMIT 32
 
-Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print)
+static Scheme_Hash_Table *setup_datum_graph(Scheme_Object *o, int for_write, void *for_print)
 {
   Scheme_Hash_Table *ht;
   int counter = 1;
@@ -743,7 +746,7 @@ Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print)
   } else
     ht = scheme_make_hash_table(SCHEME_hash_ptr);
 
-  setup_graph_table(o, ht, &counter, (PrintParams *)for_print);
+  setup_graph_table(o, for_write, ht, &counter, (PrintParams *)for_print);
 
   if (counter > 1)
     return ht;
@@ -847,12 +850,12 @@ print_to_string(Scheme_Object *obj,
     cycles = check_cycles_fast(obj, (PrintParams *)&params, &fast_checker_counter);
     if (cycles == -1) {
       ht = scheme_make_hash_table(SCHEME_hash_ptr);
-      cycles = check_cycles(obj, ht, (PrintParams *)&params);
+      cycles = check_cycles(obj, write, ht, (PrintParams *)&params);
     }
   }
 
   if (cycles)
-    ht = scheme_setup_datum_graph(obj, (PrintParams *)&params);
+    ht = setup_datum_graph(obj, write, (PrintParams *)&params);
   else
     ht = NULL;
 
@@ -2488,7 +2491,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
       pp->print_box = 1;
       
       q_ht = scheme_make_hash_table(SCHEME_hash_ptr);
-      setup_graph_table(v, q_ht, &counter, pp);
+      setup_graph_table(v, notdisplay, q_ht, &counter, pp);
 
       if (compact)
 	print_compact(pp, CPT_QUOTE);
@@ -3251,7 +3254,7 @@ static Scheme_Object *accum_write(void *_b, int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
-static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp)
+static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp)
 {
   Scheme_Object *v, *o, *a[3], *b, *accum_proc;
   Scheme_Output_Port *op;
@@ -3275,7 +3278,7 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, PrintParams *pp)
 
   a[0] = s;
   a[1] = o;
-  a[2] = scheme_false;
+  a[2] = (for_write ? scheme_true : scheme_false);
 
   scheme_apply_multi(v, 3, a);
 

src/mzscheme/src/schpriv.h

@@ -804,7 +804,6 @@ int scheme_stx_proper_list_length(Scheme_Object *list);
 Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx);
 
 Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj);
-Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print);
 
 Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *stx);