Racket experiments

svn: r18725

collects/compiler/embed-unit.ss

@@ -746,21 +746,19 @@
     
     ;; Write a module bundle that can be loaded with 'load' (do not embed it
     ;; into an executable). The bundle is written to the current output port.
-    (define (do-write-module-bundle outp verbose? modules literal-files literal-expressions collects-dest
+    (define (do-write-module-bundle outp verbose? modules config? literal-files literal-expressions collects-dest
                                     on-extension program-name compiler expand-namespace 
                                     src-filter get-extra-imports)
       (let* ([module-paths (map cadr modules)]
-             [files (map
+             [resolve-one-path (lambda (mp)
-                     (lambda (mp)
                                  (let ([f (resolve-module-path mp #f)])
                                    (unless f
                                      (error 'write-module-bundle "bad module path: ~e" mp))
-                         (normalize f)))
+                                   (normalize f)))]
-                     module-paths)]
+             [files (map resolve-one-path module-paths)]
-             [collapsed-mps (map
+             [collapse-one (lambda (mp)
-                             (lambda (mp)
+                             (collapse-module-path mp (build-path (current-directory) "dummy.ss")))]
-                               (collapse-module-path mp (build-path (current-directory) "dummy.ss")))
+             [collapsed-mps (map collapse-one module-paths)]
-                             module-paths)]
              [prefix-mapping (map (lambda (f m)
                                     (cons f (let ([p (car m)])
                                               (cond
@@ -774,13 +772,27 @@
                                   files modules)]
              ;; Each element is created with `make-mod'.
              ;; As we descend the module tree, we append to the front after
-             ;; loasing imports, so the list in the right order.
+             ;; loading imports, so the list in the right order.
-             [codes (box null)])
+             [codes (box null)]
-        (for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose? collects-dest
+             [get-code-at (lambda (f mp)
+                            (get-code f mp codes prefix-mapping verbose? collects-dest
                                            on-extension compiler expand-namespace
-                                           get-extra-imports))
+                                           get-extra-imports))]
-                  files
+             [__
-                  collapsed-mps)
+              ;; Load all code:
+              (for-each get-code-at files collapsed-mps)]
+             [config-info (and config?
+                               (let ([a (assoc (car files) (unbox codes))])
+                                 (let ([info (module-compiled-language-info (mod-code a))])
+                                   (when info
+                                     (let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1))
+                                                      (vector-ref info 2))])
+                                       (get-info 'configure-runtime #f))))))])
+        ;; Add module for runtime configuration:
+        (when config-info
+          (let ([mp (vector-ref config-info 0)])
+            (get-code-at (resolve-one-path mp)
+                         (collapse-one mp))))
         ;; Drop elements of `codes' that just record copied libs:
         (set-box! codes (filter mod-code (unbox codes)))
         ;; Bind `module' to get started:
@@ -917,6 +929,12 @@
         (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp)
         (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
         (newline outp)
+        (when config-info
+          (let ([a (assoc (resolve-one-path (vector-ref config-info 0)) (unbox codes))])            
+            (write (compile-using-kernel `((dynamic-require '',(mod-full-name a)
+                                                            ',(vector-ref config-info 1))
+                                           ',(vector-ref config-info 2)))
+                   outp)))
         (for-each (lambda (f)
                     (when verbose?
                       (fprintf (current-error-port) "Copying from ~s~n" f))
@@ -928,6 +946,7 @@
 
     (define (write-module-bundle #:verbose? [verbose? #f]
                                  #:modules [modules null]
+                                 #:configure-via-first-module? [config? #f]
                                  #:literal-files [literal-files null]
                                  #:literal-expressions [literal-expressions null]
                                  #:on-extension [on-extension #f]
@@ -937,7 +956,7 @@
                                                           (compile expr)))]
                                  #:src-filter [src-filter (lambda (filename) #f)]
                                  #:get-extra-imports [get-extra-imports (lambda (filename code) null)])
-      (do-write-module-bundle (current-output-port) verbose? modules literal-files literal-expressions
+      (do-write-module-bundle (current-output-port) verbose? modules config? literal-files literal-expressions
                               #f ; collects-dest
                               on-extension
                               "?" ; program-name 
@@ -970,6 +989,7 @@
                                          #:mred? [mred? #f]
                                          #:verbose? [verbose? #f]
                                          #:modules [modules null]
+                                         #:configure-via-first-module? [config? #f]
                                          #:literal-files [literal-files null]
                                          #:literal-expression [literal-expression #f]
                                          #:literal-expressions [literal-expressions
@@ -1086,7 +1106,7 @@
             (let ([write-module
                    (lambda (s)
                      (do-write-module-bundle s
-                                             verbose? modules literal-files literal-expressions collects-dest
+                                             verbose? modules config? literal-files literal-expressions collects-dest
                                              on-extension
                                              (file-name-from-path dest)
                                              compiler

collects/compiler/main.ss

@@ -569,6 +569,7 @@
       #:modules (cons `(#%mzc: (file ,(car source-files)))
                       (map (lambda (l) `(#t (lib ,l)))
                            (exe-embedded-libraries)))
+      #:configure-via-first-module? #t
       #:literal-expression
       (parameterize ([current-namespace (make-base-namespace)])
         (compile

collects/mzlib/pconvert.ss

@@ -1,10 +1,8 @@
 
 (module pconvert mzscheme
   
-  (require (only "string.ss" expr->string)
+  (require (only "list.ss" sort)
-           (only "list.ss" sort)
            scheme/mpair
-	   "etc.ss"
 	   "pconvert-prop.ss"
            "class.ss")
   
@@ -169,7 +167,7 @@
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (define map-share-name
     (lambda (name)
-      (string->symbol (string-append "-" (expr->string name) "-"))))
+      (string->symbol (format "-~s-" name))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; prints an expression given that it has already been hashed. This
@@ -458,8 +456,7 @@
 						  [str-name (if (string? name)
 								name
 								(symbol->string name))])
-					     (string->symbol (string-append "make-" str-name))))]
+					     (string->symbol (string-append "make-" str-name))))])
-				      [uniq (begin-lifted (box #f))])
                                   `(,constructor
                                     ,@(map (lambda (x) 
                                              (if (eq? uniq x)
@@ -497,6 +494,7 @@
       [(null? x) null]
       [else (f x)]))
   
+  (define uniq (gensym))
   
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; these functions get the list of shared items.  If just-circular is
@@ -536,8 +534,8 @@
                     (get-shared-helper csi))
                   (get-shared-helper csi))]
              [cmp (lambda (x y)
-                    (string<? (expr->string (share-info-name (car x)))
+                    (string<? (format "~s" (share-info-name (car x)))
-                              (expr->string (share-info-name (car y)))))])
+                              (format "~s" (share-info-name (car y)))))])
          (map cdr (sort shared-listss cmp)))]))
   
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

collects/racket/base.ss

@@ -0,0 +1,6 @@
+#lang racket/private
+(require "private/define-struct.ss")
+
+(provide (except-out (all-from-out scheme/base)
+                     define-struct)
+         (rename-out [new-define-struct define-struct]))

collects/racket/base/lang/reader.ss

@@ -0,0 +1,5 @@
+#lang s-exp syntax/module-reader
+racket/base
+
+#:info get-info
+(require racket/private/get-info)

collects/racket/init.ss

@@ -0,0 +1,15 @@
+#lang racket
+(require scheme/enter
+         scheme/help
+         "private/runtime.ss")
+
+;; Set the printer:
+(current-print (let ([pretty-printer
+                      (lambda (v)
+                        (unless (void? v)
+                          (pretty-print v)))])
+                 pretty-printer))
+
+(provide (all-from-out racket
+                       scheme/enter
+                       scheme/help))

collects/racket/lang/reader.ss

@@ -0,0 +1,6 @@
+#lang s-exp syntax/module-reader
+racket
+
+#:info get-info
+(require racket/private/get-info)
+

collects/racket/main.ss

@@ -0,0 +1,8 @@
+#lang racket/private
+(require scheme)
+
+(require "private/define-struct.ss")
+
+(provide (except-out (all-from-out scheme)
+                     define-struct)
+         (rename-out [new-define-struct define-struct]))

collects/racket/private/define-struct.ss

@@ -0,0 +1,23 @@
+#lang scheme/base
+(require (for-syntax scheme/base))
+
+(provide new-define-struct)
+
+(define-syntax (new-define-struct stx)
+  (define (config-has-name? config)
+    (cond
+     [(syntax? config) (config-has-name? (syntax-e config))]
+     [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
+                         (config-has-name? (cdr config)))]
+     [else #f]))
+  (with-syntax ([orig stx])
+    (syntax-case stx ()
+      [(_ id+super fields . config)
+       (not (config-has-name? #'config))
+       (with-syntax ([id (syntax-case #'id+super ()
+                           [(id super) #'id]
+                           [else #'id+super])])
+         (syntax/loc stx
+           (define-struct/derived orig id+super fields  #:constructor-name id . config)))]
+      [_ (syntax/loc stx
+           (define-struct/derived orig id+super fields . config))])))

collects/racket/private/get-info.ss

@@ -0,0 +1,12 @@
+#lang scheme/base
+
+(provide get-info)
+
+(define get-info
+  (lambda (key def get-default)
+    (case key
+      [(configure-runtime)
+       '#(racket/private/runtime configure #f)]
+      [else
+       (get-default key def)])))
+

collects/racket/private/lang/reader.ss

@@ -0,0 +1,5 @@
+#lang s-exp syntax/module-reader
+scheme/base
+
+#:info get-info
+(require racket/private/get-info)

collects/racket/private/runtime.ss

@@ -0,0 +1,7 @@
+#lang scheme/base
+(require mzlib/pconvert)
+
+(provide configure)
+
+(define (configure config)
+  (print-as-quasiquote #t))

collects/scheme/pretty.ss

@@ -13,6 +13,7 @@
    (require mzlib/private/port)
 
    (provide pretty-print
+            pretty-write
 	    pretty-display
 	    pretty-print-columns
 	    pretty-print-depth
@@ -202,7 +203,7 @@
                           res)))))
 
    (define make-pretty-print
-     (lambda (display?)
+     (lambda (display? as-qq?)
        (letrec ([pretty-print
 		 (case-lambda 
 		  [(obj port)
@@ -220,6 +221,7 @@
 							(pretty-print-print-line))
 				    (print-graph) (print-struct) (print-hash-table)
 				    (and (not display?) (print-vector-length)) (print-box) 
+                                    (and (not display?) as-qq? (print-as-quasiquote))
 				    (pretty-print-depth)
 				    (lambda (o display?)
 				      (size-hook o display? port)))
@@ -227,8 +229,9 @@
 		  [(obj) (pretty-print obj (current-output-port))])])
 	 pretty-print)))
 
-   (define pretty-print (make-pretty-print #f))
+   (define pretty-print (make-pretty-print #f #t))
-   (define pretty-display (make-pretty-print #t))
+   (define pretty-display (make-pretty-print #t #f))
+   (define pretty-write (make-pretty-print #f #f))
 
    (define-struct mark (str def))
    (define-struct hide (val))
@@ -398,8 +401,11 @@
               (vector-set! v 0 d)
               #t))))
 
+   (define-struct unquoted (val))
+
    (define (generic-write obj display? width pport
-			  print-graph? print-struct? print-hash-table? print-vec-length? print-box?
+			  print-graph? print-struct? print-hash-table? print-vec-length? 
+                          print-box? print-as-qq?
 			  depth size-hook)
 
      (define pair-open (if (print-pair-curly-braces) "{" "("))
@@ -589,17 +595,20 @@
 		       (expr-found pport ref))
 		     (n-k)))))))
 
-     (define (write-custom recur obj pport depth display? width)
+     (define (write-custom recur obj pport depth display? width qd)
        (let-values ([(l c p) (port-next-location pport)])
 	 (let ([p (relocate-output-port pport l c p)])
 	   (port-count-lines! p)
 	   (let ([writer (lambda (v port)
-			   (recur port v (dsub1 depth) #f))]
+			   (recur port v (dsub1 depth) #f qd))]
 		 [displayer (lambda (v port)
-			      (recur port v (dsub1 depth) #t))])
+			      (recur port v (dsub1 depth) #t qd))]
+                 [printer (case-lambda 
+                           [(v port) (recur port v (dsub1 depth) #t qd)]
+                           [(v port qd) (recur port v (dsub1 depth) #t qd)])])
 	     (port-write-handler p writer)
 	     (port-display-handler p displayer)
-	     (port-print-handler p writer))
+	     (port-print-handler p printer))
 	   (register-printing-port-like p pport)
 	   (parameterize ([pretty-printing #t]
 			  [pretty-print-columns (or width 'infinity)])
@@ -607,23 +616,23 @@
 
      ;; ------------------------------------------------------------
      ;; wr: write on a single line
-     (define (wr* pport obj depth display?)
+     (define (wr* pport obj depth display? qd)
 
        (define (out str)
 	 (write-string str pport))
        
-       (define (wr obj depth)
+       (define (wr obj depth qd)
-	 (wr* pport obj depth display?))
+	 (wr* pport obj depth display? qd))
 
-       (define (wr-expr expr depth pair? car cdr open close)
+       (define (wr-expr expr depth pair? car cdr open close qd)
-	 (if (and (read-macro? expr pair? car cdr)
+	 (if (and (read-macro? expr pair? car cdr qd)
                   (equal? open "("))
 	     (begin
 	       (out (read-macro-prefix expr car))
-	       (wr (read-macro-body expr car cdr) depth))
+	       (wr (read-macro-body expr car cdr) depth (reader-adjust-qd (car expr) qd)))
-	     (wr-lst expr #t depth pair? car cdr open close)))
+	     (wr-lst expr #t depth pair? car cdr open close qd)))
 
-       (define (wr-lst l check? depth pair? car cdr open close)
+       (define (wr-lst l check? depth pair? car cdr open close qd)
 	 (if (pair? l)
 	     (check-expr-found 
 	      l pport check?
@@ -636,33 +645,35 @@
                       (out close))
 		    (begin
 		      (out open)
-		      (wr (car l) (dsub1 depth))
+		      (wr (car l) (dsub1 depth) qd)
 		      (let loop ([l (cdr l)])
 			(check-expr-found
 			 l pport (and check? (pair? l))
 			 (lambda (s) (out " . ") (out s) (out close))
 			 (lambda ()
 			   (out " . ")
-			   (wr-lst l check? (dsub1 depth) pair? car cdr open close)
+			   (wr-lst l check? (dsub1 depth) pair? car cdr open close qd)
 			   (out close))
 			 (lambda ()
 			   (cond 
 			    [(pair? l) 
-			     (if (and (eq? (car l) 'unquote)
+			     (if (and (eq? (do-remap (car l)) 'unquote)
+                                      (not (equal? qd 1))
 				      (pair? (cdr l))
 				      (null? (cdr (cdr l))))
 				 (begin
 				   (out " . ,")
-				   (wr (car (cdr l)) (dsub1 depth))
+				   (wr (car (cdr l)) (dsub1 depth)
+                                       (reader-adjust-qd (car l) qd))
 				   (out close))
 				 (begin
 				   (out " ")
-				   (wr (car l) (dsub1 depth))
+				   (wr (car l) (dsub1 depth) qd)
 				   (loop (cdr l))))]
 			    [(null? l) (out close)]
 			    [else
 			     (out " . ")
-			     (wr l (dsub1 depth))
+			     (wr l (dsub1 depth) qd)
 			     (out close)]))))))))
              (begin
                (out open)
@@ -681,28 +692,33 @@
 		  (output-hooked pport obj len display?))]
 	    
 	    [(pair? obj) 
-	     (wr-expr obj depth pair? car cdr pair-open pair-close)]
+             (let ([qd (to-quoted out qd "`")])
+               (wr-expr obj depth pair? car cdr pair-open pair-close qd))]
 	    [(mpair? obj) 
-	     (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close)]
+             (let ([qd (to-quoted out qd "`")])
+               (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close qd))]
 	    [(null? obj)
-	     (wr-lst obj #f depth pair? car cdr "(" ")")]
+             (let ([qd (to-quoted out qd "'")])
+               (wr-lst obj #f depth pair? car cdr "(" ")" qd))]
 	    [(vector? obj)   
              (check-expr-found
               obj pport #t
               #f #f
               (lambda ()
+                (let ([qd (to-quoted out qd "`")])
                   (out "#")
                   (when print-vec-length?
                     (out (number->string (vector-length obj))))
-		(wr-lst (vector->repeatless-list obj) #f depth pair? car cdr "(" ")")))]
+                  (wr-lst (vector->repeatless-list obj) #f depth pair? car cdr "(" ")" qd))))]
 	    [(and (box? obj)
                   print-box?)
              (check-expr-found
               obj pport #t
               #f #f
               (lambda ()
+                (let ([qd (to-quoted out qd "`")])
                   (out "#&") 
-		(wr (unbox obj) (dsub1 depth))))]
+                  (wr (unbox obj) (dsub1 depth) qd))))]
 	    [(and (custom-write? obj) 
 		  (not (struct-type? obj)))
 	     (check-expr-found
@@ -710,7 +726,7 @@
 	      #f #f
 	      (lambda ()
 		(parameterize ([pretty-print-columns 'infinity])
-		  (write-custom wr* obj pport depth display? width))))]
+		  (write-custom wr* obj pport depth display? width qd))))]
 	    [(struct? obj)
 	     (if (and print-struct?
 		      (not (and depth
@@ -719,11 +735,21 @@
 		  obj pport #t
 		  #f #f
 		  (lambda ()
+                    (let* ([v (struct->vector obj)]
+                           [pf? (prefab?! obj v)])
+                      (let ([qd (if pf?
+                                    (to-quoted out qd "`")
+                                    (to-unquoted out qd))])
+                        (when (or (not qd) pf?)
                           (out "#")
-                    (let ([v (struct->vector obj)])
+                          (when pf? (out "s")))
-                      (when (prefab?! obj v)
+                        (wr-lst (let ([l (vector->list v)])
-                        (out "s"))
+                                  (if (and qd (not pf?))
-                      (wr-lst (vector->list v) #f (dsub1 depth) pair? car cdr "(" ")"))))
+                                      (cons (make-unquoted (object-name obj))
+                                            (cdr l))
+                                      l))
+                                #f (dsub1 depth) pair? car cdr "(" ")" 
+                                qd)))))
                  (parameterize ([print-struct #f])
 		   ((if display? orig-display orig-write) obj pport)))]
 	    [(hash-table? obj)  
@@ -734,6 +760,7 @@
 		  obj pport #t
 		  #f #f
 		  (lambda ()
+                    (let ([qd (to-quoted out qd "`")])
                       (out (if (hash-table? obj 'equal)
                                "#hash"
                                (if (hash-table? obj 'eqv)
@@ -742,11 +769,11 @@
                       (wr-lst (hash-table-map obj (lambda (k v)
                                                     (cons k (make-hide v))))
                               #f depth
-                            pair? car cdr "(" ")")))
+                              pair? car cdr "(" ")" qd))))
 		 (parameterize ([print-hash-table #f])
 		   ((if display? orig-display orig-write) obj pport)))]
             [(hide? obj)
-             (wr* pport (hide-val obj) depth display?)]
+             (wr* pport (hide-val obj) depth display? qd)]
 	    [(boolean? obj)
 	     (out (if obj "#t" "#f"))]
 	    [(number? obj)
@@ -760,6 +787,18 @@
 	    [(and (pretty-print-.-symbol-without-bars)
 		  (eq? obj '|.|))
 	     (out ".")]
+            [(and (equal? qd 1)
+                  (or (eq? 'unquote obj)
+                      (eq? 'unquote-splicing obj)))
+             (out ",'")
+             (orig-write obj pport)]
+            [(and qd (or (symbol? obj)
+                         (keyword? obj)))
+             (to-quoted out qd "'")
+             (orig-write obj pport)]
+            [(unquoted? obj)
+             (let ([qd (to-unquoted out qd)])
+               (orig-write (unquoted-val obj) pport))]
 	    [else
 	     ((if display? orig-display orig-write) obj pport)]))
        (unless (hide? obj)
@@ -767,10 +806,10 @@
 
      ;; ------------------------------------------------------------
      ;; pp: write on (potentially) multiple lines
-     (define (pp* pport obj depth display?)
+     (define (pp* pport obj depth display? qd)
 
        (define (pp obj depth)
-	 (pp* pport obj depth display?))
+	 (pp* pport obj depth display? qd))
 
        (define (out str)
 	 (write-string str pport))
@@ -790,7 +829,7 @@
 		   (spaces (- to col))))
 	       (spaces (max 0 (- to col))))))
 
-       (define (pr obj extra pp-pair depth)
+       (define (pr obj extra pp-pair depth qd)
 	 ;; may have to split on multiple lines
 	 (let* ([can-multi (and width
                                 (not (size-hook obj display?))
@@ -819,7 +858,7 @@
 					   (- width extra)
 					   (lambda () (esc a-pport)))])
 			  ;; Here's the attempt to write on one line:
-			  (wr* a-pport obj depth display?)
+			  (wr* a-pport obj depth display? qd)
 			  a-pport))])
 		 (let-values ([(l c p) (port-next-location a-pport)])
 		   (if (<= c (- width extra))
@@ -835,43 +874,62 @@
 			 (pre-print pport obj)
 			 (cond
 			  [(pair? obj) (pp-pair obj extra depth 
-                                                pair? car cdr pair-open pair-close)]
+                                                pair? car cdr pair-open pair-close
+                                                qd)]
                           [(mpair? obj) (pp-pair obj extra depth 
-                                                 mpair? mcar mcdr mpair-open mpair-close)]
+                                                 mpair? mcar mcdr mpair-open mpair-close
+                                                 qd)]
 			  [(vector? obj)
+                           (let ([qd (to-quoted out qd "`")])
                              (out "#")
                              (when print-vec-length?
                                (out (number->string (vector-length obj))))
                              (pp-list (vector->repeatless-list obj) extra pp-expr #f depth
-                                    pair? car cdr pair-open pair-close)]
+                                      pair? car cdr pair-open pair-close
+                                      qd))]
 			  [(and (custom-write? obj)
 				(not (struct-type? obj)))
-			   (write-custom pp* obj pport depth display? width)]
+                           (let ([qd (to-unquoted out qd)])
+                             (write-custom pp* obj pport depth display? width qd))]
 			  [(struct? obj) ; print-struct is on if we got here
+                           (let* ([v (struct->vector obj)]
+                                  [pf? (prefab?! obj v)])
+                             (let ([qd (if pf?
+                                           (to-quoted out qd "`")
+                                           (to-unquoted out qd))])
+                               (when (or (not qd) pf?)
                                  (out "#")
-                           (let ([v (struct->vector obj)])
+                                 (when pf? (out "s")))
-                             (when (prefab?! obj v)
+                               (pp-list (let ([l (vector->list v)])
-                               (out "s"))
+                                          (if (and qd (not pf?))
-                             (pp-list (vector->list v) extra pp-expr #f depth
+                                              (cons (make-unquoted (object-name v))
-                                      pair? car cdr pair-open pair-close))]
+                                                    (cdr l))
+                                              l))
+                                        extra pp-expr #f depth
+                                        pair? car cdr pair-open pair-close
+                                        qd)))]
 			  [(hash-table? obj)
+                           (let ([qd (to-quoted out qd "`")])
                              (out (if (hash-table? obj 'equal)
                                       "#hash"
                                       (if (hash-table? obj 'eqv)
                                           "#hasheqv"
                                           "#hasheq")))
                              (pp-list (hash-table-map obj cons) extra pp-expr #f depth
-                                    pair? car cdr pair-open pair-close)]
+                                      pair? car cdr pair-open pair-close
+                                      qd))]
 			  [(and (box? obj) print-box?)
+                           (let ([qd (to-quoted out qd "`")])
                              (out "#&") 
-			   (pr (unbox obj) extra pp-pair depth)])
+                             (pr (unbox obj) extra pp-pair depth qd))])
 			 (post-print pport obj)))))
 	       ;; Not possible to split obj across lines; so just write directly
-	       (wr* pport obj depth display?))))
+	       (wr* pport obj depth display? qd))))
 
        (define (pp-expr expr extra depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close
-	 (if (and (read-macro? expr apair? acar acdr)
+                        qd)
+	 (if (and (read-macro? expr apair? acar acdr qd)
                   (equal? open "(")
                   (not (and found (hash-table-get found (acdr expr) #f))))
 	     (begin
@@ -879,15 +937,18 @@
 	       (pr (read-macro-body expr acar acdr)
 		   extra
 		   pp-expr
-		   depth))
+		   depth
+                   (reader-adjust-qd (acar expr) qd)))
 	     (let ((head (acar expr)))
 	       (if (or (and (symbol? head)
                             (not (size-hook head display?)))
                        ((pretty-print-remap-stylable) head))
 		   (let ((proc (style head expr apair? acar acdr)))
 		     (if proc
+                         (let ([qd (to-quoted out qd "`")])
                            (proc expr extra depth
-                               apair? acar acdr open close)
+                                 apair? acar acdr open close
+                                 qd))
 			 (if (and #f
                                   ;; Why this special case? Currently disabled.
                                   (> (string-length 
@@ -897,62 +958,74 @@
                                            ((pretty-print-remap-stylable) head))))
                                      max-call-head-width))
                              (pp-general expr extra #f #f #f pp-expr depth
-                                         apair? acar acdr open close)
+                                         apair? acar acdr open close
+                                         qd)
 			     (pp-list expr extra pp-expr #t depth
-                                      apair? acar acdr open close))))
+                                      apair? acar acdr open close
+                                      qd))))
 		   (pp-list expr extra pp-expr #t depth
-                            apair? acar acdr open close)))))
+                            apair? acar acdr open close
+                            qd)))))
 
-       (define (wr obj depth)
+       (define (wr obj depth qd)
-	 (wr* pport obj depth display?))
+	 (wr* pport obj depth display? qd))
 
        ;; (head item1
        ;;       item2
        ;;       item3)
        (define (pp-call expr extra pp-item depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close
+                        qd)
          (out open)
-	 (wr (acar expr) (dsub1 depth))
+         (wr (acar expr) (dsub1 depth) qd)
          (let ([col (+ (ccol) 1)])
            (pp-down close (acdr expr) col col extra pp-item #t #t depth
-                    apair? acar acdr open close)))
+                    apair? acar acdr open close
+                    qd)))
 
        ;; (head item1 item2
        ;;   item3
        ;;   item4)
        (define (pp-two-up expr extra pp-item depth
-                          apair? acar acdr open close)
+                          apair? acar acdr open close
+                          qd)
 	 (out open)
 	 (let ([col (ccol)])
-	   (wr (acar expr) (dsub1 depth))
+	   (wr (acar expr) (dsub1 depth) qd)
 	   (out " ")
-	   (wr (acar (acdr expr)) (dsub1 depth))
+	   (wr (acar (acdr expr)) (dsub1 depth) qd)
 	   (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
-                    apair? acar acdr open close)))
+                    apair? acar acdr open close 
+                    qd)))
 
        ;; (head item1
        ;;   item2
        ;;   item3)
        (define (pp-one-up expr extra pp-item depth
-                          apair? acar acdr open close)
+                          apair? acar acdr open close
+                          qd)
 	 (out open)
 	 (let ([col (ccol)])
-	   (wr (acar expr) (dsub1 depth))
+	   (wr (acar expr) (dsub1 depth) qd)
 	   (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
-                    apair? acar acdr open close)))
+                    apair? acar acdr open close 
+                    qd)))
 
        ;; (item1
        ;;  item2
        ;;  item3)
        (define (pp-list l extra pp-item check? depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close
+                        qd)
 	 (out open)
 	 (let ([col (ccol)])
 	   (pp-down close l col col extra pp-item #f check? depth
-                    apair? acar acdr open close)))
+                    apair? acar acdr open close
+                    qd)))
 
        (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close 
+                        qd)
 	 (let loop ([l l] [icol col1] [check? check-first?])
 	   (check-expr-found
 	    l pport (and check? (apair? l))
@@ -966,7 +1039,7 @@
 	      (indent col2)
 	      (out ".")
 	      (indent col2)
-	      (pr l extra pp-item depth)
+	      (pr l extra pp-item depth qd)
 	      (out closer))
 	    (lambda ()
 	      (cond 
@@ -974,7 +1047,7 @@
 		(let ([rest (acdr l)])
 		  (let ([extra (if (null? rest) (+ extra 1) 0)])
 		    (indent icol)
-		    (pr (acar l) extra pp-item (dsub1 depth))
+		    (pr (acar l) extra pp-item (dsub1 depth) qd)
 		    (loop rest col2 check-rest?)))]
 	       [(null? l)
 		(out closer)]
@@ -982,11 +1055,12 @@
 		(indent col2)
 		(out ".")
 		(indent col2)
-		(pr l (+ extra 1) pp-item (dsub1 depth))
+		(pr l (+ extra 1) pp-item (dsub1 depth) qd)
 		(out closer)])))))
 
        (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth
-                           apair? acar acdr open close)
+                           apair? acar acdr open close
+                           qd)
 
 	 (define (tail1 rest col1 col3)
 	   (if (and pp-1 (apair? rest))
@@ -994,7 +1068,7 @@
 		      (rest (acdr rest))
 		      (extra (if (null? rest) (+ extra 1) 0)))
 		 (indent col3)
-		 (pr val1 extra pp-1 depth)
+		 (pr val1 extra pp-1 depth qd)
 		 (tail2 rest col1 col3))
 	       (tail2 rest col1 col3)))
 
@@ -1004,88 +1078,113 @@
 		      (rest (acdr rest))
 		      (extra (if (null? rest) (+ extra 1) 0)))
 		 (indent col3)
-		 (pr val1 extra pp-2 depth)
+		 (pr val1 extra pp-2 depth qd)
 		 (tail3 rest col1))
 	       (tail3 rest col1)))
 
 	 (define (tail3 rest col1)
 	   (pp-down close rest col1 col1 extra pp-3 #f #t depth
-                    apair? acar acdr open close))
+                    apair? acar acdr open close
+                    qd))
 
 	 (let* ([head (acar expr)]
 		[rest (acdr expr)]
 		[col (ccol)])
 	   (out open)
-	   (wr head (dsub1 depth))
+	   (wr head (dsub1 depth) qd)
 	   (if (and named? (apair? rest))
 	       (let* ((name (acar rest))
 		      (rest (acdr rest)))
 		 (out " ")
-		 (wr name (dsub1 depth))
+		 (wr name (dsub1 depth) qd)
 		 (tail1 rest (+ col indent-general) (+ (ccol) 1)))
 	       (tail1 rest (+ col indent-general) (+ (ccol) 1)))))
 
        (define (pp-expr-list l extra depth
-                             apair? acar acdr open close)
+                             apair? acar acdr open close
+                             qd)
 	 (pp-list l extra pp-expr #t depth
-                  apair? acar acdr open close))
+                  apair? acar acdr open close
+                  qd))
 
        (define (pp-lambda expr extra depth
-                          apair? acar acdr open close)
+                          apair? acar acdr open close
+                          qd)
 	 (pp-general expr extra #f pp-expr-list #f pp-expr depth
-                     apair? acar acdr open close))
+                     apair? acar acdr open close
+                     qd))
 
        (define (pp-if expr extra depth
-                      apair? acar acdr open close)
+                      apair? acar acdr open close
+                      qd)
 	 (pp-general expr extra #f pp-expr #f pp-expr depth
-                     apair? acar acdr open close))
+                     apair? acar acdr open close
+                     qd))
 
        (define (pp-cond expr extra depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close
+                        qd)
 	 (pp-list expr extra pp-expr-list #t depth
-                  apair? acar acdr open close))
+                  apair? acar acdr open close
+                  qd))
 
        (define (pp-syntax-case expr extra depth
-                               apair? acar acdr open close)
+                               apair? acar acdr open close
+                               qd)
 	 (pp-two-up expr extra pp-expr-list depth
-                    apair? acar acdr open close))
+                    apair? acar acdr open close
+                    qd))
 
        (define (pp-module expr extra depth
-                          apair? acar acdr open close)
+                          apair? acar acdr open close
+                          qd)
          (pp-two-up expr extra pp-expr depth
-                    apair? acar acdr open close))
+                    apair? acar acdr open close
+                    qd))
 
        (define (pp-make-object expr extra depth
-                               apair? acar acdr open close)
+                               apair? acar acdr open close
+                               qd)
 	 (pp-one-up expr extra pp-expr-list depth
-                    apair? acar acdr open close))
+                    apair? acar acdr open close
+                    qd))
 
        (define (pp-case expr extra depth
-                        apair? acar acdr open close)
+                        apair? acar acdr open close
+                        qd)
 	 (pp-general expr extra #f pp-expr #f pp-expr-list depth
-                     apair? acar acdr open close))
+                     apair? acar acdr open close
+                     qd))
 
        (define (pp-and expr extra depth
-                       apair? acar acdr open close)
+                       apair? acar acdr open close
+                       qd)
 	 (pp-call expr extra pp-expr depth
-                  apair? acar acdr open close))
+                  apair? acar acdr open close
+                  qd))
 
        (define (pp-let expr extra depth
-                       apair? acar acdr open close)
+                       apair? acar acdr open close
+                       qd)
 	 (let* ((rest (acdr expr))
 		(named? (and (apair? rest) (symbol? (do-remap (acar rest))))))
 	   (pp-general expr extra named? pp-expr-list #f pp-expr depth
-                       apair? acar acdr open close)))
+                       apair? acar acdr open close
+                       qd)))
 
        (define (pp-begin expr extra depth
-                         apair? acar acdr open close)
+                         apair? acar acdr open close
+                         qd)
 	 (pp-general expr extra #f #f #f pp-expr depth
-                     apair? acar acdr open close))
+                     apair? acar acdr open close
+                     qd))
 
        (define (pp-do expr extra depth
-                      apair? acar acdr open close)
+                      apair? acar acdr open close
+                      qd)
 	 (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth
-                     apair? acar acdr open close))
+                     apair? acar acdr open close
+                     qd))
 
        ;; define formatting style (change these to suit your style)
 
@@ -1155,16 +1254,33 @@
 
 	   (else #f)))
 
-       (pr obj 0 pp-expr depth))
+       (pr obj 0 pp-expr depth qd))
+
+     (define (to-quoted out qd str)
+       (and qd
+            (if (zero? qd)
+                (begin
+                  (out str)
+                  (add1 qd))
+                qd)))
+
+     (define (to-unquoted out qd)
+       (and qd
+            (if (zero? qd)
+                qd
+                (begin
+                  (out ",")
+                  (to-unquoted out (sub1 qd))))))
 
      ;; ------------------------------------------------------------
      ;; This is where generic-write's body expressions start
 
      ((printing-port-print-line pport) #t 0 width)
+     (let ([qd (if print-as-qq? 0 #f)])
        (let-values ([(l col p) (port-next-location pport)])
          (if (and width (not (eq? width 'infinity)))
-	   (pp* pport obj depth display?)
+             (pp* pport obj depth display? qd)
-	   (wr* pport obj depth display?)))
+             (wr* pport obj depth display? qd))))
      (let-values ([(l col p) (port-next-location pport)])
        ((printing-port-print-line pport) #f col width)))
   
@@ -1183,16 +1299,26 @@
        values]
       [else raw-head]))
    
-   (define (read-macro? l pair? car cdr)
+  (define (read-macro? l pair? car cdr qd)
      (define (length1? l) (and (pair? l) (null? (cdr l))))
      (and (pretty-print-abbreviate-read-macros)
           (let ((head (do-remap (car l))) (tail (cdr l)))
             (case head
-              ((quote quasiquote unquote unquote-splicing syntax
+              ((quote quasiquote syntax
                 quasisyntax unsyntax unsyntax-splicing)
                (length1? tail))
+              ((unquote unquote-splicing)
+               (and (not (equal? qd 1))
+                    (length1? tail)))
               (else #f)))))
 
+  (define (reader-adjust-qd v qd)
+    (and qd
+         (case (do-remap v)
+           [(quasiquote) (add1 qd)]
+           [(unquote unquote-splciing) (sub1 qd)]
+           [else qd])))
+            
    (define (read-macro-body l car cdr)
      (car (cdr l)))
   

collects/scheme/private/define-struct.ss

@@ -39,6 +39,34 @@
                                               "procedure (arity 0)"
                                               proc)))))
 
+  (define-for-syntax (self-ctor-transformer orig stx)
+    (with-syntax ([orig orig])
+      (syntax-case stx ()
+        [(_ arg ...) (datum->syntax stx
+                                    (syntax-e (syntax (orig arg ...)))
+                                    stx
+                                    stx)]
+        [_ (syntax orig)])))
+  
+  (define-values-for-syntax (make-self-ctor-struct-info)
+    (letrec-values ([(struct: make- ? ref set!)
+                     (make-struct-type 'self-ctor-struct-info struct:struct-info
+                                       1 0 #f
+                                       (list (cons prop:procedure
+                                                   (lambda (v stx)
+                                                     (self-ctor-transformer (ref v 0) stx))))
+                                       (current-inspector) #f '(0))])
+      make-))
+  (define-values-for-syntax (make-self-ctor-checked-struct-info)
+    (letrec-values ([(struct: make- ? ref set!)
+                     (make-struct-type 'self-ctor-checked-struct-info struct:checked-struct-info
+                                       1 0 #f
+                                       (list (cons prop:procedure
+                                                   (lambda (v stx)
+                                                     (self-ctor-transformer (ref v 0) stx))))
+                                       (current-inspector) #f '(0))])
+      make-))
+
   (define-syntax-parameter struct-field-index
     (lambda (stx)
       (raise-syntax-error #f "allowed only within a structure type definition" stx)))
@@ -92,15 +120,16 @@
        stx
        (if (null? alt) kw (car alt))))
 
-    (define (check-exprs orig-n ps)
+    (define (check-exprs orig-n ps what)
       (let loop ([nps (cdr ps)][n orig-n])
         (unless (zero? n)
           (unless (and (pair? nps)
                        (not (keyword? (syntax-e (car nps)))))
             (raise-syntax-error
              #f
-             (format "expected ~a expression~a after keyword~a"
+             (format "expected ~a ~a~a after keyword~a"
                      orig-n
+                     (or what "expression")
                      (if (= orig-n 1) "" "s")
                      (if (pair? nps)
                          ", found a keyword"
@@ -129,7 +158,7 @@
              (loop (cdr ps) def-val auto? #t)]
             #;
             [(eq? #:default (syntax-e (car ps)))
-             (check-exprs 1 ps)
+             (check-exprs 1 ps #f)
              (when def-val
                (bad "multiple" (car ps) " for field"))
              (loop (cddr ps) (cadr ps) auto? mutable?)]
@@ -173,13 +202,14 @@
                            (#:props . ())
                            (#:mutable . #f)
                            (#:guard . #f)
+                           (#:constructor-name . #f)
                            (#:omit-define-values . #f)
                            (#:omit-define-syntaxes . #f))]
                  [nongen? #f])
         (cond
          [(null? p) config]
          [(eq? '#:super (syntax-e (car p)))
-          (check-exprs 1 p)
+          (check-exprs 1 p #f)
           (when (lookup config '#:super)
             (bad "multiple" (car p) "s"))
           (when super-id
@@ -196,7 +226,7 @@
          [(memq (syntax-e (car p))
                 '(#:guard #:auto-value))
           (let ([key (syntax-e (car p))])
-            (check-exprs 1 p)
+            (check-exprs 1 p #f)
             (when (lookup config key)
               (bad "multiple" (car p) "s"))
             (when (and nongen?
@@ -206,7 +236,7 @@
                   (extend-config config key (cadr p))
                   nongen?))]
          [(eq? '#:property (syntax-e (car p)))
-          (check-exprs 2 p)
+          (check-exprs 2 p #f)
           (when nongen?
             (bad "cannot use" (car p) " for prefab structure type"))
           (loop (cdddr p)
@@ -216,7 +246,7 @@
                                      (lookup config '#:props)))
                 nongen?)]
          [(eq? '#:inspector (syntax-e (car p)))
-          (check-exprs 1 p)
+          (check-exprs 1 p #f)
           (when (lookup config '#:inspector)
             (bad "multiple" insp-keys "s" (car p)))
           (loop (cddr p)
@@ -229,6 +259,15 @@
           (loop (cdr p)
                 (extend-config config '#:inspector #'#f)
                 nongen?)]
+         [(eq? '#:constructor-name (syntax-e (car p)))
+          (check-exprs 1 p "identifier")
+          (when (lookup config '#:constructor-name)
+            (bad "multiple #:constructor-name keys" (car p)))
+          (unless (identifier? (cadr p))
+            (bad "need an identifier after #:constructor-name" (cadr p)))
+          (loop (cddr p)
+                (extend-config config '#:constructor-name (cadr p))
+                nongen?)]
          [(eq? '#:prefab (syntax-e (car p)))
           (when (lookup config '#:inspector)
             (bad "multiple" insp-keys "s" (car p)))
@@ -321,7 +360,7 @@
                          (car field-stxes))]
                        [else
                         (loop (cdr fields) (cdr field-stxes) #f)]))])
-               (let-values ([(inspector super-expr props auto-val guard mutable?
+               (let*-values ([(inspector super-expr props auto-val guard ctor-name mutable?
                                          omit-define-values? omit-define-syntaxes?)
                               (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
                                 (values (lookup config '#:inspector)
@@ -329,9 +368,12 @@
                                         (lookup config '#:props)
                                         (lookup config '#:auto-value)
                                         (lookup config '#:guard)
+                                        (lookup config '#:constructor-name)
                                         (lookup config '#:mutable)
                                         (lookup config '#:omit-define-values)
-                                       (lookup config '#:omit-define-syntaxes)))])
+                                        (lookup config '#:omit-define-syntaxes)))]
+                             [(self-ctor?)
+                              (and ctor-name (bound-identifier=? id ctor-name))])
                  (when mutable?
                    (for-each (lambda (f f-stx)
                                (when (field-mutable? f)
@@ -342,7 +384,11 @@
                                   f-stx)))
                              fields field-stxes))
                  (let ([struct: (build-name id "struct:" id)]
-                       [make- (build-name id "make-" id)]
+                       [make- (if ctor-name
+                                  (if self-ctor?
+                                      (car (generate-temporaries (list id)))
+                                      ctor-name)
+                                  (build-name id "make-" id))]
                        [? (build-name id id "?")]
                        [sels (map (lambda (f)
                                     (build-name id ; (field-id f) 
@@ -407,7 +453,8 @@
                                                                         [(not (or mutable? (field-mutable? (car fields))))
                                                                          (cons i (loop (add1 i) (cdr fields)))]
                                                                         [else (loop (add1 i) (cdr fields))]))
-                                                                  #,guard))])
+                                                                  #,guard
+                                                                  '#,ctor-name))])
                                   (values struct: make- ?
                                           #,@(let loop ([i 0][fields fields])
                                                (if (null? fields)
@@ -429,8 +476,12 @@
                                                       #`(quote-syntax #,(prune sel))
                                                       sel)))]
 				  [mk-info (if super-info-checked?
-					       #'make-checked-struct-info
+                                               (if self-ctor?
-					       #'make-struct-info)])
+                                                   #'make-self-ctor-checked-struct-info
+                                                   #'make-checked-struct-info)
+                                               (if self-ctor?
+                                                   #'make-self-ctor-struct-info
+                                                   #'make-struct-info))])
                               (quasisyntax/loc stx
                                 (define-syntaxes (#,id)
                                   (#,mk-info
@@ -465,7 +516,10 @@
                                             (protect super-id)
                                             (if super-expr
                                                 #f
-                                                #t)))))))))])
+                                                #t))))
+                                   #,@(if self-ctor?
+                                          (list #`(quote-syntax #,make-))
+                                          null))))))])
                      (let ([result
                             (cond
                              [(and (not omit-define-values?) (not omit-define-syntaxes?))

collects/scribblings/mzc/exe-api.scrbl

@@ -46,6 +46,9 @@ parameter is true.
                                           (listof (list/c (or/c symbol? (one-of/c #t #f)) 
                                                           module-path?))
                                           null]
+                               [#:configure-via-first-module? config-via-first? 
+                                                              any/c 
+                                                              #f]
                                [#:literal-files literal-files
                                                 (listof path-string?)
                                                 null]
@@ -119,6 +122,12 @@ bindings; use compiled expressions to bootstrap the namespace. If
 included in the executable. The @scheme[#:literal-expression]
 (singular) argument is for backward compatibility.
 
+If the @scheme[#:configure-via-first-module?] argument is specified as
+true, then the language of the first module in @scheme[mod-list] is
+used to configure the run-time environment before the expressions
+added by @scheme[#:literal-files] and @scheme[#:literal-expressions]
+are evaluated.
+
 The @scheme[#:cmdline] argument @scheme[cmdline] contains command-line
 strings that are prefixed onto any actual command-line arguments that
 are provided to the embedding executable. A command-line argument that

collects/scribblings/reference/custom-write.scrbl

@@ -6,19 +6,22 @@
 @defthing[prop:custom-write struct-type-property?]{
 
 Associates a procedure to a structure type to used by the default
-printer to @scheme[display] or @scheme[write] (or @scheme[print])
+printer to @scheme[display], @scheme[write], or @scheme[print]
 instances of the structure type.
 
 @moreref["structprops"]{structure type properties}
 
 The procedure for a @scheme[prop:custom-write] value takes three
-arguments: the structure to be printed, the target port, and a boolean
+arguments: the structure to be printed, the target port, and an
-that is @scheme[#t] for @scheme[write] mode and @scheme[#f] for
+argument that is @scheme[#t] for @scheme[write] mode, @scheme[#f] for
-@scheme[display] mode. The procedure should print the value to the
+@scheme[display] mode, or an exact non-negative integer representing
-given port using @scheme[write], @scheme[display], @scheme[fprintf],
+the current @scheme[quasiquote] depth for @scheme[print] mode.  The
+procedure should print the value to the given port using
+@scheme[write], @scheme[display], @scheme[print], @scheme[fprintf],
 @scheme[write-special], etc.
 
-The write handler, display handler, and print handler are specially
+The @tech{port write handler}, @tech{port display handler}, 
+and @tech{print handler} are specially
 configured for a port given to a custom-write procedure. Printing to
 the port through @scheme[display], @scheme[write], or @scheme[print]
 prints a value recursively with sharing annotations. To avoid a
@@ -41,21 +44,25 @@ limited width).
 
 The following example definition of a @scheme[tuple] type includes
 custom-write procedures that print the tuple's list content using
-angle brackets in @scheme[write] mode and no brackets in
+angle brackets in @scheme[write] and @scheme[print] mode and no brackets in
 @scheme[display] mode. Elements of the tuple are printed recursively,
 so that graph and cycle structure can be represented.
 
 @defexamples[
-(define (tuple-print tuple port write?)
+(define (tuple-print tuple port mode)
-  (when write? (write-string "<" port))
+  (when mode (write-string "<" port))
-  (let ([l (tuple-ref tuple 0)])
+  (let ([l (tuple-ref tuple 0)]
+        [recur (case mode
+                 [(#t) write]
+                 [(#f) display]
+                 [else (lambda (p port) (print p port mode))])])
     (unless (zero? (vector-length l))
-      ((if write? write display) (vector-ref l 0) port)
+      (recur (vector-ref l 0) port)
       (for-each (lambda (e)
                   (write-string ", " port)
-                  ((if write? write display) e port))
+                  (recur e port))
                 (cdr (vector->list l)))))
-  (when write? (write-string ">" port)))
+  (when mode (write-string ">" port)))
 
 (define-values (s:tuple make-tuple tuple? tuple-ref tuple-set!)
   (make-struct-type 'tuple #f 1 0 #f
@@ -63,6 +70,8 @@ so that graph and cycle structure can be represented.
 
 (display (make-tuple #(1 2 "a")))
 
+(print (make-tuple #(1 2 "a")))
+
 (let ([t (make-tuple (vector 1 2 "a"))])
   (vector-set! (tuple-ref t 0) 0 t)
   (write t))

collects/scribblings/reference/define-struct.scrbl

@@ -24,6 +24,7 @@
                               (code:line #:property prop-expr val-exr)
                               (code:line #:transparent)
                               (code:line #:prefab)
+                              (code:line #:constructor-name constructor-id)
                               #:omit-define-syntaxes
                               #:omit-define-values]
                [field-option #:mutable
@@ -41,7 +42,8 @@ to @math{4+2n} names:
  @item{@schemeidfont{struct:}@scheme[id], a @deftech{structure type
        descriptor} value that represents the @tech{structure type}.}
 
- @item{@schemeidfont{make-}@scheme[id], a @deftech{constructor}
+ @item{@scheme[constructor-id] (which defaults to
+       @schemeidfont{make-}@scheme[id]), a @deftech{constructor}
        procedure that takes @math{m} arguments and returns a new
        instance of the @tech{structure type}, where @math{m} is the
        number of @scheme[field]s that do not include an
@@ -72,7 +74,10 @@ to @math{4+2n} names:
        is used to define subtypes, and it also works with the
        @scheme[shared] and @scheme[match] forms. For detailed
        information about the binding of @scheme[id], see
-       @secref["structinfo"].}
+       @secref["structinfo"].
+       
+       The @scheme[constructor-id] and @scheme[id] can be the same, in
+       which case @scheme[id] performs both roles.}
 
 ]
 
@@ -119,8 +124,9 @@ must also be a @tech{prefab} structure type.
 If the @scheme[#:omit-define-syntaxes] option is supplied, then
 @scheme[id] is not bound as a transformer. If the
 @scheme[#:omit-define-values] option is supplied, then none of the
-usual variables are bound. If both are supplied, then the
+usual variables are bound, but @scheme[id] is bound. If both are
-@scheme[define-struct] form is equivalent to @scheme[(begin)].
+supplied, then the @scheme[define-struct] form is equivalent to
+@scheme[(begin)].
 
 If @scheme[#:auto] is supplied as a @scheme[field-option], then the
 @tech{constructor} procedure for the structure type does not accept an

collects/scribblings/reference/module-reflect.scrbl

@@ -305,11 +305,11 @@ module's declaration though the @indexed-scheme['module-language]
 If no information is available for the module, the result is
 @scheme[#f]. Otherwise, the result is @scheme[(vector _mp _name _val)]
 such that @scheme[((dynamic-require _mp _name) _val)] should return
-function that takes a single argument. The function's argument is a
+function that takes two arguments. The function's arguments are a key
-key for reflected information, and the result is a value associated
+for reflected information and a default value.  Acceptable keys and
-with that key.  Acceptable keys and the interpretation of results is
+the interpretation of results is up to external tools, such as
-up to external tools, such as DrScheme.  If no information is
+DrScheme.  If no information is available for a given key, the result
-available for a given key, the result should be @scheme[#f].
+should be the given default value.
 
 See also @scheme[module->language-info].}
 
@@ -367,14 +367,18 @@ more than the namespace's @tech{base phase}.}
 
 
 @defproc[(module->language-info 
-          [mod (or/c module-path? path? resolved-module-path?)])
+          [mod (or/c module-path? path? resolved-module-path?)]
+          [load? any/c #f])
          (or/c #f (vector/c module-path? symbol? any/c))]{
 
 Returns information intended to reflect the ``language'' of the
-implementation of @scheme[mod], which must be declared (but not
+implementation of @scheme[mod]. If @scheme[load?] is @scheme[#f], the
-necessarily @tech{instantiate}d or @tech{visit}ed) in the current
+module named by @scheme[mod] must be declared (but not necessarily
-namespace. The information is the same as would have been returned by
+@tech{instantiate}d or @tech{visit}ed) in the current namespace;
-@scheme[module-compiled-language-info] applied to the module's
+otherwise, @scheme[mod] may be loaded (as for @scheme[dynamic-require]
+and other functions). The information returned by
+@scheme[module->language-info] is the same as would have been returned
+by @scheme[module-compiled-language-info] applied to the module's
 implementation as compiled code.}
 
 

collects/scribblings/reference/pretty-print.scrbl

@@ -9,19 +9,20 @@
 @defproc[(pretty-print [v any/c] [port output-port? (current-output-port)])
          void?]{
 
-Pretty-prints the value @scheme[v] using the same printed form as
+Pretty-prints the value @scheme[v] using the same printed form as the
-@scheme[write], but with newlines and whitespace inserted to avoid
+default @scheme[print] mode, but with newlines and whitespace inserted
-lines longer than @scheme[(pretty-print-columns)], as controlled by
+to avoid lines longer than @scheme[(pretty-print-columns)], as
-@scheme[(pretty-print-current-style-table)]. The printed form ends in
+controlled by @scheme[(pretty-print-current-style-table)]. The printed
-a newline, unless the @scheme[pretty-print-columns] parameter is set
+form ends in a newline, unless the @scheme[pretty-print-columns]
-to @scheme['infinity].
+parameter is set to @scheme['infinity].
 
 In addition to the parameters defined in this section,
 @scheme[pretty-print] conforms to the @scheme[print-graph],
 @scheme[print-struct], @scheme[print-hash-table],
-@scheme[print-vector-length], and @scheme[print-box] parameters.
+@scheme[print-vector-length], @scheme[print-box], and
+@scheme[print-as-quasiquote] parameters.
 
-The pretty printer also detects structures that have the
+The pretty printer detects structures that have the
 @scheme[prop:custom-write] property and it calls the corresponding
 custom-write procedure. The custom-write procedure can check the
 parameter @scheme[pretty-printing] to cooperate with the
@@ -37,12 +38,17 @@ called appropriately). Use
 @scheme[make-tentative-pretty-print-output-port] to obtain a port for
 tentative recursive prints (e.g., to check the length of the output).}
 
+@defproc[(pretty-write [v any/c] [port output-port? (current-output-port)])
+         void?]{
+
+Same as @scheme[pretty-print], but @scheme[v] is printed like
+@scheme[write] instead of like @scheme[print].}
 
 @defproc[(pretty-display [v any/c][port output-port? (current-output-port)])
          void?]{
 
 Same as @scheme[pretty-print], but @scheme[v] is printed like
-@scheme[display] instead of like @scheme[write].}
+@scheme[display] instead of like @scheme[print].}
 
 
 @defproc[(pretty-format [v any/c][columns exact-nonnegative-integer? (pretty-print-columns)])

collects/scribblings/reference/printer.scrbl

@@ -9,7 +9,11 @@ using @scheme[read] on the output produces a value that is
 @scheme[equal?] to the printed value---when the printed is used in
 @scheme[write]. When the printer is used in @scheme[display] mode, the
 printing of strings, byte strings, characters, and symbols changes to
-render the character/byte content directly to the output port.
+render the character/byte content directly to the output port. The
+printer's @scheme[print] mode is similar to @scheme[write], but it is
+sensitive to the @scheme[print-as-quasiquote] parameter for printing
+values in a way that @scheme[read] plus @scheme[eval] on the output
+can be @scheme[equal?] to the printed value.
 
 When the @scheme[print-graph] parameter is set to @scheme[#t], then
 the printer first scans an object to detect cycles. The scan traverses
@@ -63,10 +67,18 @@ Symbols @scheme[display] without escaping or quoting special
 characters. That is, the display form of a symbol is the same as the
 display form of @scheme[symbol->string] applied to the symbol.
 
+Symbols @scheme[print] the same as they @scheme[write], unless
+@scheme[print-as-quasiquote] is set to @scheme[#t] and the current
+@scheme[quasiquote] depth is @scheme[0]. In that case, the symbol's
+@scheme[print]ed form is prefixed with @litchar{'}. If the current
+@scheme[quasiquote] depth is @scheme[1], and if the symbol is
+@scheme['unquote] or @scheme[quasiquote], then the @scheme[print]ed
+form is prefixed with @litchar{,'}.
+
 @section{Printing Numbers}
 
-A number prints the same way in @scheme[write] and @scheme[display]
+A number prints the same way in @scheme[write], @scheme[display], and
-modes.
+@scheme[print] modes.
 
 A @tech{complex number} that is not a @tech{real number} always prints
 as @nonterm{m}@litchar{+}@nonterm{n}@litchar{i}, where @nonterm{m} and
@@ -94,14 +106,15 @@ printed form of its exact negation.
 @section{Printing Booleans}
 
 The constant @scheme[#t] prints as @litchar{#t}, and the constant
-@scheme[#f] prints as @litchar{#f} in both @scheme[display] and
+@scheme[#f] prints as @litchar{#f} in all modes (@scheme[display],
-@scheme[write] modes.
+@scheme[write], and @scheme[print]).
 
-@section{Printing Pairs and Lists}
+@section[#:tag "print-pairs"]{Printing Pairs and Lists}
 
-A pair prints starting with @litchar{(} followed by the printed form
+In @scheme[write] and @scheme[display] modes, an empty list prints as
-of its @scheme[car]. The rest of the printed form depends on the
+@litchar{()}. A pair normally prints starting with @litchar{(}
-@scheme[cdr]:
+followed by the printed form of its @scheme[car]. The rest of the
+printed form depends on the @scheme[cdr]:
 
 @itemize[
 
@@ -116,9 +129,33 @@ of its @scheme[car]. The rest of the printed form depends on the
 
 ]
 
+If @scheme[print-reader-abbreviations] is set to @scheme[#t], then
+pair printing is adjusted in the case of a pair that starts a
+two-element list whose first element is @scheme[quote],
+@scheme['quasiquote], @scheme['unquote], @scheme['unquote-splicing],
+@scheme['syntax], @scheme['quasisyntax], @scheme['unsyntax],
+@scheme['unsyntax-splicing]. In that case, the pair is printed with
+the corresponding reader syntax: @litchar{'}, @litchar{`},
+@litchar{,}, @litchar[",@"], @litchar{#'}, @litchar{#`}, @litchar{#,},
+or @litchar["#,@"], respectively. After the reader syntax, the second
+element of the list is printed. When the list is a tail of an
+enclosing list, the tail is printed after a @litchar{.} in the
+enclosing list (after which the reader abbreviations work), instead of
+including the tail as two elements of the enclosing list.
+
 The printed form of a pair is the same in both @scheme[write] and
 @scheme[display] modes, except as the printed form of the pair's
-@scheme[car]and @scheme[cdr] vary with the mode.
+@scheme[car] and @scheme[cdr] vary with the mode. The @scheme[print]
+form is also the same is @scheme[print-as-quasiquote] is @scheme[#f].
+
+When @scheme[print-as-quasiquote] is @scheme[#t] and the current
+@scheme[quasiquote] depth is @scheme[0], then the empty list prints as
+@litchar{'()} and a pair's output is prefixed with @litchar{`}; the
+pair's content is printed at @scheme[quasiquote] depth is
+@scheme[1]. In addition, when @scheme['quasiquote], @scheme['unquote],
+or @scheme['unquote-splicing] appears as the first element of a
+two-element list, the @scheme[quasiquote] depth is adjusted
+appropriately for printing the second element of the list.
 
 By default, mutable pairs (as created with @scheme[mcons]) print the
 same as pairs, except that @litchar["{"] and @litchar["}"] are used
@@ -136,7 +173,7 @@ set to @scheme[#f], then mutable pairs print using @litchar{(} and
 
 All strings @scheme[display] as their literal character sequences.
 
-The @scheme[write] form of a string starts with @litchar{"} and ends
+The @scheme[write] or @scheme[print] form of a string starts with @litchar{"} and ends
 with another @litchar{"}. Between the @litchar{"}s, each character is
 represented. Each graphic or blank character is represented as itself,
 with two exceptions: @litchar{"} is printed as @litchar{\"}, and
@@ -154,7 +191,7 @@ All byte strings @scheme[display] as their literal byte sequence; this
 byte sequence may not be a valid UTF-8 encoding, so it may not
 correspond to a sequence of characters.
 
-The @scheme[write] form a byte string starts with @litchar{#"} and
+The @scheme[write] or @scheme[print] form a byte string starts with @litchar{#"} and
 ends with another @litchar{"}. Between the @litchar{"}s, each byte is
 written using the corresponding ASCII decoding if the byte is between
 0 and 127 and the character is graphic or blank (according to
@@ -171,7 +208,13 @@ followed by the printed form of @scheme[vector->list] applied to the
 vector. In @scheme[write] mode, the printed form is the same, except
 that when the @scheme[print-vector-length] parameter is @scheme[#t], a
 decimal integer is printed after the @litchar{#}, and a repeated last
-element is printed only once..
+element is printed only once.
+
+Vectors @scheme[print] the same as they @scheme[write], unless
+@scheme[print-as-quasiquote] is set to @scheme[#t] and the current
+@scheme[quasiquote] depth is @scheme[0]. In that case, the vector's
+@scheme[print]ed form is prefixed with @litchar{`}, and its content is
+printed with @scheme[quasiquote] depth @scheme[1].
 
 
 @section[#:tag "print-structure"]{Printing Structures}
@@ -185,7 +228,13 @@ for which the structure is an instance:
  @item{If the structure type is a @techlink{prefab} structure type,
        then it prints using @litchar{#s(} followed by the @tech{prefab}
        structure type key, then the printed form each field in the
-       structure, and then @litchar{)}.}
+       structure, and then @litchar{)}.
+
+       In @scheme[print] mode when @scheme[print-as-quasiquote] is set
+       to @scheme[#t] and the current @scheme[quasiquote] depth is
+       @scheme[0], the structure's @scheme[print]ed form is prefixed
+       with @litchar{`} and its content is printed with
+       @scheme[quasiquote] depth @scheme[1].}
 
  @item{If the structure has a @scheme[prop:custom-write] property
        value, then the associated procedure is used to print the
@@ -193,7 +242,18 @@ for which the structure is an instance:
 
  @item{If the structure type is transparent, or if any ancestor is
        transparent, then the structure prints as the vector produced
-       by @scheme[struct->vector].}
+       by @scheme[struct->vector] in @scheme[display] mode, in
+       @scheme[write] mode, or in @scheme[print] mode when
+       @scheme[print-as-quasiquote] is set to @scheme[#f].
+
+       In @scheme[print] mode with @scheme[print-as-quasiquote] as
+       @scheme[#t], then the printed form is prefixed with as many
+       @litchar{,}s as the current @scheme[quasiquote] depth. Instead
+       of printing as a vector, the structure content is printed as a
+       list, where the first element is the list is the structure's
+       type name (as determined by @scheme[object-name]) printed in
+       @scheme[write] mode, while the remaining elements are
+       @scheme[print]ed at @scheme[quasiquote] depth @scheme[0].}
 
  @item{For any other structure type, the structure prints as an
        unreadable value; see @secref["print-unreadable"] for more
@@ -217,6 +277,14 @@ additional space if the key--value pair is not the last to be printed.
 After all key-value pairs, the printed form completes with
 @litchar{)}.
 
+In @scheme[print] mode when @scheme[print-as-quasiquote] is
+@scheme[#t] and the current quasiquote depth is @scheme[0], then the
+printed form is prefixed with @litchar{`} and the hash table's content
+is printed at @scheme[quasiquote] depth @scheme[1]. In the printed
+form, keys may be printed with @litchar{,} escapes, even though
+@scheme[quasiquote] does not support @scheme[unquote] escapes in the
+key position.
+
 When the @scheme[print-hash-table] parameter is set to @scheme[#f], a
 hash table prints (un@scheme[read]ably) as @litchar{#<hash>}.
 
@@ -224,6 +292,10 @@ hash table prints (un@scheme[read]ably) as @litchar{#<hash>}.
 
 When the @scheme[print-box] parameter is set to @scheme[#t], 
 a box prints as @litchar{#&} followed by the printed form of its content.
+In @scheme[print] mode when @scheme[print-as-quasiquote] is
+@scheme[#t] and the current quasiquote depth is @scheme[0], then the
+printed form is prefixed with @litchar{`} and the box's content
+is printed at @scheme[quasiquote] depth @scheme[1].
 
 When the @scheme[print-box] parameter is set to @scheme[#f], a box
 prints (un@scheme[read]ably) as @litchar{#<box>}.
@@ -231,7 +303,7 @@ prints (un@scheme[read]ably) as @litchar{#<box>}.
 @section{Printing Characters}
 
 Characters with the special names described in
-@secref["parse-character"] @scheme[write] using the same name.
+@secref["parse-character"] @scheme[write] and @scheme[print] using the same name.
 (Some characters have multiple names; the @scheme[#\newline] and
 @scheme[#\nul] names are used instead of @scheme[#\linefeed] and
 @scheme[#\null]).  Other graphic characters (according to
@@ -246,15 +318,16 @@ character).
 
 @section{Printing Keywords}
 
-Keywords @scheme[write] and @scheme[display] the same as symbols,
+Keywords @scheme[write], @scheme[print], and @scheme[display] the same as symbols,
-except (see @secref["print-symbol"]) with a leading @litchar{#:},
+except (see @secref["print-symbol"]) with a leading @litchar{#:} (after any 
+@litchar{'} prefix added in @scheme[print] mode),
 and without special handing for an initial @litchar{#} or when the
 printed form would matches a number or a delimited @litchar{.} (since
 @litchar{#:} distinguishes the keyword).
 
 @section{Printing Regular Expressions}
 
-Regexp values in both @scheme[write] and @scheme[display] mode print
+Regexp values in all modes (@scheme[write], @scheme[display], and @scheme[print])
 starting with @litchar{#px} (for @scheme[pregexp]-based regexps) or
 @litchar{#rx} (for @scheme[regexp]-based regexps) followed by the
 @scheme[write] form of the regexp's source string or byte string.

collects/scribblings/reference/startup.scrbl

@@ -62,15 +62,22 @@ command line does not specify a @scheme[require] flag
 @Flag{u}/@DFlag{require-script}) before any @scheme[eval],
 @scheme[load], or read-eval-print-loop flag (@Flag{e}/@DFlag{eval},
 @Flag{f}/@DFlag{load}, @Flag{r}/@DFlag{script}, @Flag{m}/@DFlag{main},
-or @Flag{i}/@DFlag{repl}). The
+or @Flag{i}/@DFlag{repl}). The initialization library can be changed
-initialization library can be changed with the @Flag{I}
+with the @Flag{I} @tech{configuration option}. The
-@tech{configuration option}.
+@scheme['configure-runtime] property of the initialization library's
+language is used before the library is instantiated; see
+@secref["configure-runtime"].
 
 After potentially loading the initialization module, expression
 @scheme[eval]s, files @scheme[load]s, and module @scheme[require]s are
 executed in the order that they are provided on the command line. If
 any raises an uncaught exception, then the remaining @scheme[eval]s,
-@scheme[load]s, and @scheme[require]s are skipped.
+@scheme[load]s, and @scheme[require]s are skipped. If the first
+@scheme[require] precedes any @scheme[eval] or @scheme[load] so that
+the initialization library is skipped, then the
+@scheme['configure-runtime] property of the required module's library
+language is used before the module is instantiated; see
+@secref["configure-runtime"].
 
 After running all command-line expressions, files, and modules,
 MzScheme or MrEd then starts a read-eval-print loop for interactive
@@ -362,3 +369,34 @@ of the collapsed set.
 
 Extra arguments following the last option are available from the
 @indexed-scheme[current-command-line-arguments] parameter.
+
+@; ----------------------------------------------------------------------
+
+@section[#:tag "configure-runtime"]{Language Run-Time Configuration}
+
+When a module is implemented using @hash-lang{}, the language after
+@hash-lang{} can specify configuration actions to perform when a
+module using the language is the main module of a program. The
+language specifies run-time configuration by
+
+@itemlist[
+
+ @item{attaching a @scheme['module-language] @tech{syntax property} to
+       the module as read from its source (see @scheme[module] and
+       @scheme[module-compiled-language-info]);}
+
+ @item{having the function indicated by the @scheme['module-language]
+       @tech{syntax property} recognize the
+       @scheme['configure-runtime] key, for which it returns another
+       vector: @scheme[(vector _mp _name _val)] where @scheme[_mp] is
+       a @tech{module path}, @scheme[_name] is a symbol, and
+       @scheme[_val] is an arbitrary value; and}
+
+ @item{having the function called as @scheme[((dynamic-require _mp
+       _name) _val)] configure the run-time environment, typically by
+       setting parameters such as @scheme[current-print].}
+
+]
+
+The @schememodname[scheme/base] and @schememodname[scheme] languages
+do not currently specify a run-time configuration action.

collects/scribblings/reference/struct.scrbl

@@ -99,7 +99,8 @@ override the default @scheme[equal?] definition through the
                                       #f]
                            [immutables (listof exact-nonnegative-integer?)
                                        null]
-                           [guard (or/c procedure? #f) #f])
+                           [guard (or/c procedure? #f) #f]
+                           [constructor-name (or/c symbol? #f) #f])
           (values struct-type?
                   struct-constructor-procedure?
                   struct-predicate-procedure?
@@ -169,6 +170,10 @@ values produced by the subtype's guard procedure become the first
 @math{n} arguments to @scheme[guard]. When @scheme[inspector] is
 @scheme['prefab], then @scheme[guard] must be @scheme[#f].
 
+If @scheme[constructor-name] is not @scheme[#f], it is used as the
+name of the generated @tech{constructor} procedure as returned by
+@scheme[object-name] or in the printed form of the constructor value.
+
 The result of @scheme[make-struct-type] is five values:
 
 @itemize[

collects/scribblings/reference/stx-trans.scrbl

@@ -67,18 +67,25 @@ A @tech{structure type property} to identify structure types that act
 as @tech{assignment transformers} like the ones created by
 @scheme[make-set!-transformer].
 
-The property value must be an exact integer or procedure of one
+The property value must be an exact integer or procedure of one or two
-argument. In the former case, the integer designates a field within
+arguments. In the former case, the integer designates a field within
 the structure that should contain a procedure; the integer must be
 between @scheme[0] (inclusive) and the number of non-automatic fields
 in the structure type (exclusive, not counting supertype fields), and
 the designated field must also be specified as immutable.
 
-If the property value is an procedure, then the procedure serves as a
+If the property value is an procedure of one argument, then the
-@tech{syntax transformer} and for @scheme[set!] transformations. If
+procedure serves as a @tech{syntax transformer} and for @scheme[set!]
-the property value is an integer, the target identifier is extracted
+transformations. If the property value is a procedure of two
-from the structure instance; if the field value is not a procedure of
+arguments, then the first argument is the structure whose type has
-one argument, then a procedure that always calls
+@scheme[prop:set!-transformer] property, and the second argument is a
+syntax object as for a @tech{syntax transformer} and for @scheme[set!]
+transformations; @scheme[set!-transformer-procedure] applied to the
+structure produces a new function that accepts just the syntax object
+and call the procedure associated through the property. Finally, if the
+property value is an integer, the target identifier is extracted from
+the structure instance; if the field value is not a procedure of one
+argument, then a procedure that always calls
 @scheme[raise-syntax-error] is used, instead.
 
 If a value has both the @scheme[prop:set!-transformer] and

collects/scribblings/reference/write.scrbl

@@ -43,7 +43,8 @@ printer. In particular, note that @scheme[display] may require memory
 proportional to the depth of the value being printed, due to the
 initial cycle check.}
 
-@defproc[(print [datum any/c][out output-port? (current-output-port)])
+@defproc[(print [datum any/c][out output-port? (current-output-port)]
+                [exact-nonnegative-integer? qq-depth 0])
          void?]{
 
 Writes @scheme[datum] to @scheme[out], normally the same way as
@@ -52,12 +53,18 @@ Writes @scheme[datum] to @scheme[out], normally the same way as
 the handler specified by @scheme[global-port-print-handler] is called;
 the default handler uses the default printer in @scheme[write] mode.
 
+The optional @scheme[qq-depth] argument adjust printing when the
+@scheme[print-as-quasiquote] parameter is set to @scheme[#t]. In that
+case, @scheme[qq-depth] specifies the starting @scheme[quasiquote]
+depth for printing @scheme[datum].
+
 The rationale for providing @scheme[print] is that @scheme[display]
-and @scheme[write] both have relatively standard output conventions,
+and @scheme[write] both have specific output conventions, and those
-and this standardization restricts the ways that an environment can
+conventions restrict the ways that an environment can change the
-change the behavior of these procedures. No output conventions should
+behavior of @scheme[display] and @scheme[write] procedures. No output
-be assumed for @scheme[print], so that environments are free to modify
+conventions should be assumed for @scheme[print], so that environments
-the actual output generated by @scheme[print] in any way.}
+are free to modify the actual output generated by @scheme[print] in
+any way.}
 
 
 @defproc[(fprintf [out output-port?][form string?][v any/c] ...) void?]{
@@ -192,6 +199,20 @@ A parameter that controls printing vectors; defaults to
 A parameter that controls printing hash tables; defaults to
 @scheme[#f]. See @secref["print-hashtable"] for more information.}
 
+@defboolparam[print-reader-abbreviations on?]{
+
+A parameter that controls printing of two-element lists that start
+with @scheme[quote], @scheme['quasiquote], @scheme['unquote],
+@scheme['unquote-splicing], @scheme['syntax], @scheme['quasisyntax],
+@scheme['unsyntax], or @scheme['unsyntax-splicing]; defaults to
+@scheme[#f]. See @secref["print-pairs"] for more information.}
+
+@defboolparam[print-as-quasiquote on?]{
+
+A parameter that controls printing in @scheme[print] mode (as opposed
+to @scheme[write] or @scheme[display]); defaults to @scheme[#f]. See
+@secref["printing"] for more information.}
+
 @defboolparam[print-honu on?]{
 
 A parameter that controls printing values in an alternate syntax.  See
@@ -230,7 +251,7 @@ it is not @scheme[#f], otherwise the path is left relative).}
                                   [proc (any/c output-port? . -> . any)])
             void?])]{}
 
-@defproc*[([(port-print-handler [out output-port?]) (any/c output-port? . -> . any)]
+@defproc*[([(port-print-handler [out output-port?]) ((any/c output-port?) (exact-nonnegative-integer?) . ->* . any)]
            [(port-print-handler [out output-port?]
                                 [proc (any/c output-port? . -> . any)])
             void?])]{
@@ -239,20 +260,33 @@ Gets or sets the @deftech{port write handler}, @deftech{port display
 handler}, or @deftech{port print handler} for @scheme[out]. This
 handler is call to output to the port when @scheme[write],
 @scheme[display], or @scheme[print] (respectively) is applied to the
-port.  Each handler takes a two arguments: the value to be printed and
+port.  Each handler must accept two arguments: the value to be printed and
 the destination port. The handler's return value is ignored.
 
+A @tech{port print handler} optionally accepts a third argument, which
+corresponds to the optional third argument to @scheme[print]; if a
+procedure given to @scheme[port-print-handler] does not accept a third
+argument, it is wrapped with a procedure that discards the optional
+third argument.
+
 The default port display and write handlers print Scheme expressions
 with Scheme's built-in printer (see @secref["printing"]). The
 default print handler calls the global port print handler (the value
 of the @scheme[global-port-print-handler] parameter); the default
 global port print handler is the same as the default write handler.}
 
-@defparam[global-port-print-handler proc (any/c output-port? . -> . any)]{
+@defproc*[([(global-port-print-handler) ((any/c output-port?) (exact-nonnegative-integer?) . ->* . any)]
+           [(global-port-print-handler [proc (any/c output-port? . -> . any)]) void?])]{
 
 A parameter that determines @deftech{global port print handler},
 which is called by the default port print handler (see
 @scheme[port-print-handler]) to @scheme[print] values into a port.
 The default value uses the built-in printer (see
-@secref["printing"]) in @scheme[write] mode.}
+@secref["printing"]) in @scheme[print] mode.
 
+A @tech{global port print handler} optionally accepts a third
+argument, which corresponds to the optional third argument to
+@scheme[print]. If a procedure given to
+@scheme[global-port-print-handler] does not accept a third argument,
+it is wrapped with a procedure that discards the optional third
+argument.}

collects/tests/future/random-future.ss

@@ -182,7 +182,7 @@ Errors/exceptions and other kinds of control?
                (gen-exp))]))
 
 (define-namespace-anchor ns-here)
-(let ([seed 595933061 #;(+ 1 (random (expt 2 30)))])
+(let ([seed (+ 1 (random (expt 2 30)))])
   (printf "DrDr Ignore! random-seed ~s\n" seed)
   (random-seed seed))
 

collects/tests/mzscheme/file.ss

@@ -707,7 +707,7 @@
 (test "hello\"hello\"" get-output-string sp)
 (arity-test (port-display-handler sp) 2 2)
 (arity-test (port-write-handler sp) 2 2)
-(arity-test (port-print-handler sp) 2 2)
+(arity-test (port-print-handler sp) 2 3)
 (err/rt-test ((port-display-handler sp) 8 8))
 (err/rt-test ((port-write-handler sp) 8 8))
 (err/rt-test ((port-print-handler sp) 8 8))

collects/tests/mzscheme/struct.ss

@@ -16,7 +16,7 @@
   (test #f struct-type-property? 5)
   (let-values ([(type make pred sel set) (make-struct-type 'a #f 2 1 'un (list (cons prop:p 87)) (make-inspector insp1))]
 	       [(typex makex predx selx setx) (make-struct-type 'ax #f 0 5 #f null (make-inspector insp2))])
-    (arity-test make-struct-type 4 10)
+    (arity-test make-struct-type 4 11)
     (test 5 primitive-result-arity make-struct-type)
     (test #t struct-type? type)
     (test #t procedure? make)

src/mzscheme/cmdline.inc

@@ -166,16 +166,58 @@ typedef struct {
 
 typedef void (*Repl_Proc)(Scheme_Env *);
 
+static void configure_environment(Scheme_Object *mod)
+{
+  Scheme_Object *mli, *dyreq, *a[3], *gi, *v;
+
+  mli = scheme_builtin_value("module->language-info");
+
+  a[0] = mod;
+  a[1] = scheme_make_true();
+  v = scheme_apply(mli, 2, a);
+  if (SCHEME_VECTORP(v)) {
+    dyreq = scheme_builtin_value("dynamic-require");
+
+    a[0] = SCHEME_VEC_ELS(v)[0];
+    a[1] = SCHEME_VEC_ELS(v)[1];
+    gi = scheme_apply(dyreq, 2, a);
+
+    a[0] = SCHEME_VEC_ELS(v)[2];
+    gi = scheme_apply(gi, 1, a);
+
+    a[0] = scheme_intern_symbol("configure-runtime");
+    a[1] = scheme_make_false();
+    v = scheme_apply(gi, 2, a);
+    if (!SAME_OBJ(v, scheme_make_false())) {
+      if (SCHEME_VECTORP(v) && SCHEME_VEC_SIZE(v) == 3) {
+        a[0] = SCHEME_VEC_ELS(v)[0];
+        a[1] = SCHEME_VEC_ELS(v)[1];
+        a[2] = SCHEME_VEC_ELS(v)[2];
+        v = scheme_apply(dyreq, 2, a);
+        
+        a[0] = a[2];
+        scheme_apply_multi(v, 1, a);
+      } else {
+        a[0] = v;
+        scheme_wrong_type("current-print setup", "vector of three values",
+                          -1, 0, a);
+      }
+    }
+  }
+}
+
 static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 {
   volatile int exit_val = 0;
+  volatile int did_config = 0;
 
   if (fa->a->init_ns) {
-    Scheme_Object *nsreq, *a[1];
+    Scheme_Object *a[1], *nsreq;
     Scheme_Thread * volatile p;
     mz_jmp_buf * volatile save, newbuf;
 
     nsreq = scheme_builtin_value("namespace-require");
+
     a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
                             scheme_make_pair(scheme_make_utf8_string(fa->init_lib),
                                              scheme_make_null()));
@@ -183,9 +225,13 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
     p = scheme_get_current_thread();
     save = p->error_buf;
     p->error_buf = &newbuf;
-    if (!scheme_setjmp(newbuf))
+    if (!scheme_setjmp(newbuf)) {
+      if (!did_config) {
+        configure_environment(a[0]);
+        did_config = 1;
+      }
       scheme_apply(nsreq, 1, a);
-    else {
+    } else {
       exit_val = 1;
     }        
     p->error_buf = save;
@@ -238,6 +284,8 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
             a[0] = scheme_make_pair(scheme_intern_symbol(name),
                                     scheme_make_pair(scheme_make_utf8_string(fa->evals_and_loads[i]),
                                                      scheme_make_null()));
+            if (!did_config)
+              configure_environment(a[0]);
             scheme_apply(nsreq, 1, a);
           }
         } else {
@@ -307,6 +355,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 	}
 	p->error_buf = save;
       }
+      did_config = 1;
     }
   }
 #endif /* DONT_PARSE_COMMAND_LINE */

src/mzscheme/include/mzscheme.exp

@@ -355,8 +355,8 @@ scheme_compile
 scheme_read
 scheme_read_syntax
 scheme_write
-scheme_display
 scheme_print
+scheme_display
 scheme_write_w_max
 scheme_display_w_max
 scheme_print_w_max
@@ -523,6 +523,7 @@ scheme_intern_exact_char_keyword
 scheme_make_struct_values
 scheme_make_struct_names
 scheme_make_struct_type
+scheme_make_struct_type2
 scheme_make_struct_instance
 scheme_is_struct_instance
 scheme_struct_ref

src/mzscheme/include/mzscheme3m.exp

@@ -361,8 +361,8 @@ scheme_compile
 scheme_read
 scheme_read_syntax
 scheme_write
-scheme_display
 scheme_print
+scheme_display
 scheme_write_w_max
 scheme_display_w_max
 scheme_print_w_max
@@ -529,6 +529,7 @@ scheme_intern_exact_char_keyword
 scheme_make_struct_values
 scheme_make_struct_names
 scheme_make_struct_type
+scheme_make_struct_type2
 scheme_make_struct_instance
 scheme_is_struct_instance
 scheme_struct_ref

src/mzscheme/include/mzwin.def

@@ -338,8 +338,8 @@ EXPORTS
  scheme_read
  scheme_read_syntax
  scheme_write
- scheme_display
  scheme_print
+ scheme_display
  scheme_write_w_max
  scheme_display_w_max
  scheme_print_w_max
@@ -506,6 +506,7 @@ EXPORTS
  scheme_make_struct_values
  scheme_make_struct_names
  scheme_make_struct_type
+ scheme_make_struct_type2
  scheme_make_struct_instance
  scheme_is_struct_instance
  scheme_struct_ref

src/mzscheme/include/mzwin3m.def

@@ -353,8 +353,8 @@ EXPORTS
  scheme_read
  scheme_read_syntax
  scheme_write
- scheme_display
  scheme_print
+ scheme_display
  scheme_write_w_max
  scheme_display_w_max
  scheme_print_w_max
@@ -521,6 +521,7 @@ EXPORTS
  scheme_make_struct_values
  scheme_make_struct_names
  scheme_make_struct_type
+ scheme_make_struct_type2
  scheme_make_struct_instance
  scheme_is_struct_instance
  scheme_struct_ref

src/mzscheme/include/scheme.h

@@ -1191,6 +1191,8 @@ enum {
   MZCONFIG_PRINT_PAIR_CURLY,
   MZCONFIG_PRINT_MPAIR_CURLY,
   MZCONFIG_PRINT_SYNTAX_WIDTH,
+  MZCONFIG_PRINT_READER,
+  MZCONFIG_PRINT_AS_QQ,
 
   MZCONFIG_CASE_SENS,
   MZCONFIG_SQUARE_BRACKETS_ARE_PARENS,
@@ -1894,6 +1896,7 @@ extern Scheme_Extension_Table *scheme_extension_table;
 #define SCHEME_STRUCT_GEN_GET 0x20
 #define SCHEME_STRUCT_GEN_SET 0x40
 #define SCHEME_STRUCT_EXPTIME 0x80
+#define SCHEME_STRUCT_NO_MAKE_PREFIX 0x100
 
 /*========================================================================*/
 /*                           file descriptors                             */

src/mzscheme/src/error.c

@@ -3287,7 +3287,7 @@ do_raise(Scheme_Object *arg, int need_debug, int eb)
       if (need_debug) {
         msg = scheme_display_to_string(((Scheme_Structure *)arg)->slots[0], NULL);
       } else
-        msg = scheme_write_to_string(arg, NULL);
+        msg = scheme_print_to_string(arg, NULL);
       scheme_log(NULL,
                  SCHEME_LOG_WARNING,
                  0,

src/mzscheme/src/fun.c

@@ -3520,10 +3520,8 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
   return scheme_make_integer(1);
 }
 
-static Scheme_Object *object_name(int argc, Scheme_Object **argv)
+Scheme_Object *scheme_object_name(Scheme_Object *a)
 {
-  Scheme_Object *a = argv[0];
-
   if (SCHEME_CHAPERONEP(a))
     a = SCHEME_CHAPERONE_VAL(a);
 
@@ -3580,6 +3578,11 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv)
   return scheme_false;
 }
 
+static Scheme_Object *object_name(int argc, Scheme_Object **argv)
+{
+  return scheme_object_name(argv[0]);
+}
+
 Scheme_Object *scheme_arity(Scheme_Object *p)
 {
   return get_or_check_arity(p, -1, NULL);
@@ -3676,13 +3679,14 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
     while (insp->superior->superior) {
       insp = insp->superior;
     }
-    scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
+    scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
                                                                NULL,
                                                                (Scheme_Object *)insp,
                                                                4, 0,
                                                                scheme_false,
+                                                               scheme_null,
                                                                scheme_make_integer(0),
-                                                                   NULL);
+                                                               NULL, NULL);
   }
 }
 

src/mzscheme/src/module.c

@@ -398,7 +398,7 @@ void scheme_init_module(Scheme_Env *env)
   GLOBAL_PRIM_W_ARITY("resolved-module-path-name",        resolved_module_path_name,  1, 1, env);
   GLOBAL_PRIM_W_ARITY("module-provide-protected?",        module_export_protected_p,  2, 2, env);
   GLOBAL_PRIM_W_ARITY("module->namespace",                module_to_namespace,        1, 1, env);
-  GLOBAL_PRIM_W_ARITY("module->language-info",            module_to_lang_info,        1, 1, env);
+  GLOBAL_PRIM_W_ARITY("module->language-info",            module_to_lang_info,        1, 2, env);
   GLOBAL_PRIM_W_ARITY("module->imports",                  module_to_imports,          1, 1, env);
   GLOBAL_PRIM_W_ARITY2("module->exports",                 module_to_exports,          1, 1, 2, 2, env);
   GLOBAL_PRIM_W_ARITY("module-path?",                     is_module_path,             1, 1, env);
@@ -2601,7 +2601,8 @@ static Scheme_Module *module_to_(const char *who, int argc, Scheme_Object *argv[
   if (SCHEME_MODNAMEP(argv[0]))
     name = argv[0];
   else
-    name = scheme_module_resolve(scheme_make_modidx(argv[0], scheme_false, scheme_false), 1);
+    name = scheme_module_resolve(scheme_make_modidx(argv[0], scheme_false, scheme_false),
+                                 (argc > 1) ? SCHEME_TRUEP(argv[1]) : 0);
 
   if (SAME_OBJ(name, kernel_modname))
     m = kernel;

src/mzscheme/src/mzmark.c

@@ -3829,6 +3829,7 @@ static int mark_print_params_MARK(void *p, struct NewGC *gc) {
   gcMARK2(pp->inspector, gc);
   gcMARK2(pp->print_port, gc);
   gcMARK2(pp->print_buffer, gc);
+  gcMARK2(pp->depth_delta, gc);
   return
   gcBYTES_TO_WORDS(sizeof(PrintParams));
 }
@@ -3838,6 +3839,7 @@ static int mark_print_params_FIXUP(void *p, struct NewGC *gc) {
   gcFIXUP2(pp->inspector, gc);
   gcFIXUP2(pp->print_port, gc);
   gcFIXUP2(pp->print_buffer, gc);
+  gcFIXUP2(pp->depth_delta, gc);
   return
   gcBYTES_TO_WORDS(sizeof(PrintParams));
 }

src/mzscheme/src/mzmarksrc.c

@@ -1560,6 +1560,7 @@ mark_print_params {
   gcMARK2(pp->inspector, gc);
   gcMARK2(pp->print_port, gc);
   gcMARK2(pp->print_buffer, gc);
+  gcMARK2(pp->depth_delta, gc);
  size:
   gcBYTES_TO_WORDS(sizeof(PrintParams));
 }

src/mzscheme/src/portfun.c

@@ -200,14 +200,14 @@ scheme_init_port_fun(Scheme_Env *env)
 
   scheme_write_proc   = scheme_make_noncm_prim(sch_write, "write",    1, 2);
   scheme_display_proc = scheme_make_noncm_prim(display,   "display",  1, 2);
-  scheme_print_proc   = scheme_make_noncm_prim(sch_print, "print",    1, 2);
+  scheme_print_proc   = scheme_make_noncm_prim(sch_print, "print",    1, 3);
 
   /* Made as a closed prim so we can get the arity right: */
   default_read_handler = scheme_make_closed_prim_w_arity(sch_default_read_handler, NULL, "default-port-read-handler", 1, 2);
 
   default_display_handler = scheme_make_prim_w_arity(sch_default_display_handler, "default-port-display-handler", 2, 2);
   default_write_handler   = scheme_make_prim_w_arity(sch_default_write_handler,   "default-port-write-handler",   2, 2);
-  default_print_handler   = scheme_make_prim_w_arity(sch_default_print_handler,   "default-port-print-handler",   2, 2);
+  default_print_handler   = scheme_make_prim_w_arity(sch_default_print_handler,   "default-port-print-handler",   2, 3);
 
   scheme_add_global_constant("eof", scheme_eof, env);
   
@@ -342,7 +342,7 @@ void scheme_init_port_fun_config(void)
 
   REGISTER_SO(scheme_default_global_print_handler);
   scheme_default_global_print_handler
-    = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 2);
+    = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 3);
   scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler);
 
   /* Use dummy port: */
@@ -3684,6 +3684,9 @@ static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
 {
   if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-port-print-handler", "output-port", 1, argc, argv);
+  if ((argc > 2) && !scheme_nonneg_exact_p(argv[2]))
+    scheme_wrong_type("default-port-print-handler", "non-negative exact integer", 
+                      2, argc, argv);
   
   return _scheme_apply(scheme_get_param(scheme_current_config(),
 					MZCONFIG_PORT_PRINT_HANDLER),
@@ -3694,8 +3697,11 @@ static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Obj
 {
   if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-global-port-print-handler", "output-port", 1, argc, argv);
+  if ((argc > 2) && !scheme_nonneg_exact_p(argv[2]))
+    scheme_wrong_type("default-global-port-print-handler", "non-negative exact integer", 
+                      2, argc, argv);
 
-  scheme_internal_print(argv[0], argv[1]);
+  scheme_internal_print(argv[0], argv[1], argv[2]);
 
   return scheme_void;
 }
@@ -3757,17 +3763,25 @@ display_write(char *name,
   } else {
     /* print */
     Scheme_Object *h;
-    Scheme_Object *a[2];
+    Scheme_Object *a[3];
+    
+    if (argc > 2) {
+      h = argv[2];
+      if (!scheme_nonneg_exact_p(h))
+        scheme_wrong_type(name, "non-negative exact integer", 2, argc, argv);
+    } else
+      h = scheme_make_integer(0);
 
     a[0] = argv[0];
     a[1] = (Scheme_Object *)port;
+    a[2] = h;
 
     h = op->print_handler;
 
     if (!h)
-      sch_default_print_handler(2, a);
+      sch_default_print_handler(3, a);
     else
-      _scheme_apply_multi(h, 2, a);
+      _scheme_apply_multi(h, 3, a);
   }
 
   return scheme_void;
@@ -3943,6 +3957,20 @@ static Scheme_Object *port_write_handler(int argc, Scheme_Object *argv[])
   }
 }
 
+static Scheme_Object *call_print_handler(void *data, int argc, Scheme_Object *argv[])
+{
+  /* If there's a 3rd argument, drop it. */
+  return _scheme_tail_apply((Scheme_Object *)data, 2, argv);
+}
+
+static Scheme_Object *wrap_print_handler(Scheme_Object *proc)
+{
+  return scheme_make_closed_prim_w_arity(call_print_handler,
+                                         proc,
+                                         "wrapped-port-print-handler",
+                                         2, 3);
+}
+
 static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Output_Port *op;
@@ -3960,19 +3988,34 @@ static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
     scheme_check_proc_arity("port-print-handler", 2, 1, argc, argv);
     if (argv[1] == default_print_handler)
       op->print_handler = NULL;
-    else
+    else if (!scheme_check_proc_arity(NULL, 3, 1, argc, argv)) {
+      Scheme_Object *wrapped;
+      wrapped = wrap_print_handler(argv[1]);
+      op->print_handler = wrapped;
+    } else
       op->print_handler = argv[1];
 
     return scheme_void;
   }
 }
 
+static Scheme_Object *filter_print_handler(int argc, Scheme_Object **argv)
+{
+  if (scheme_check_proc_arity(NULL, 2, 0, argc, argv)) {
+    if (scheme_check_proc_arity(NULL, 3, 0, argc, argv))
+      return argv[0];
+    else
+      return wrap_print_handler(argv[0]);
+  } else
+    return NULL;
+}
+
 static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
 {
   return scheme_param_config("global-port-print-handler",
 			     scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER),
 			     argc, argv,
-			     2, NULL, NULL, 0);
+			     -1, filter_print_handler, "procedure (arity 2)", 1);
 }
 
 static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[])

src/mzscheme/src/print.c

@@ -49,11 +49,22 @@ SHARED_OK static char compacts[_CPT_COUNT_];
 SHARED_OK static Scheme_Hash_Table *global_constants_ht;
 SHARED_OK static Scheme_Object *quote_link_symbol = NULL;
 
+ROSYM Scheme_Object *quote_symbol;
+ROSYM Scheme_Object *quasiquote_symbol;
+ROSYM Scheme_Object *unquote_symbol;
+ROSYM Scheme_Object *unquote_splicing_symbol;
+ROSYM Scheme_Object *syntax_symbol;
+ROSYM Scheme_Object *quasisyntax_symbol;
+ROSYM Scheme_Object *unsyntax_symbol;
+ROSYM Scheme_Object *unsyntax_splicing_symbol;
+
 /* Flag for debugging compiled code in printed form: */
 #define NO_COMPACT 0
 
 #define PRINT_MAXLEN_MIN 3
 
+#define REASONABLE_QQ_DEPTH (1 << 29)
+
 /* locals */
 #define MAX_PRINT_BUFFER 500
 
@@ -67,6 +78,7 @@ typedef struct Scheme_Print_Params {
   char print_hash_table;
   char print_unreadable;
   char print_pair_curly, print_mpair_curly;
+  char print_reader;
   char can_read_pipe_quote;
   char case_sens;
   char honu_mode;
@@ -81,6 +93,7 @@ typedef struct Scheme_Print_Params {
   long print_syntax;
   Scheme_Object *print_port;
   mz_jmp_buf *print_escape;
+  Scheme_Object *depth_delta; /* for large qq depth */
 } PrintParams;
 
 #ifdef MZ_PRECISE_GC
@@ -88,7 +101,7 @@ static void register_traversers(void);
 #endif
 
 static void print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, 
-			  int notdisplay, long maxl, int check_honu);
+			  int notdisplay, long maxl, int check_honu, Scheme_Object *qq_depth);
 static int print(Scheme_Object *obj, int notdisplay, int compact, 
 		 Scheme_Hash_Table *ht,
                  Scheme_Marshal_Tables *mt,
@@ -100,7 +113,7 @@ static void print_pair(Scheme_Object *pair, int notdisplay, int compact,
 		       Scheme_Hash_Table *ht, 
                        Scheme_Marshal_Tables *mt,
 		       PrintParams *pp,
-                       Scheme_Type type, int round_parens);
+                       Scheme_Type type, int round_parens, int first_unquoted);
 static void print_vector(Scheme_Object *vec, int notdisplay, int compact, 
 			 Scheme_Hash_Table *ht, 
                          Scheme_Marshal_Tables *mt,
@@ -108,7 +121,8 @@ static void print_vector(Scheme_Object *vec, int notdisplay, int compact,
                          int as_prefab);
 static void print_char(Scheme_Object *chobj, int notdisplay, PrintParams *pp);
 static char *print_to_string(Scheme_Object *obj, long * volatile len, int write,
-			     Scheme_Object *port, long maxl, int check_honu);
+			     Scheme_Object *port, long maxl, int check_honu,
+                             Scheme_Object *qq_depth);
 
 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
                                 Scheme_Marshal_Tables *mt,
@@ -153,6 +167,23 @@ void scheme_init_print(Scheme_Env *env)
     compacts[i] = i;
   }
 
+  REGISTER_SO(quote_symbol);
+  REGISTER_SO(quasiquote_symbol);
+  REGISTER_SO(unquote_symbol);
+  REGISTER_SO(unquote_splicing_symbol);
+  REGISTER_SO(syntax_symbol);
+  REGISTER_SO(quasisyntax_symbol);
+  REGISTER_SO(unsyntax_symbol);
+  REGISTER_SO(unsyntax_splicing_symbol);
+  quote_symbol = scheme_intern_symbol("quote");
+  quasiquote_symbol = scheme_intern_symbol("quasiquote");
+  unquote_symbol = scheme_intern_symbol("unquote");
+  unquote_splicing_symbol = scheme_intern_symbol("unquote-splicing");
+  syntax_symbol = scheme_intern_symbol("syntax");
+  quasisyntax_symbol = scheme_intern_symbol("quasisyntax");
+  unsyntax_symbol = scheme_intern_symbol("unsyntax");
+  unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing");
+
 #ifdef MZ_PRECISE_GC
   register_traversers();
 #endif
@@ -208,14 +239,24 @@ scheme_debug_print (Scheme_Object *obj)
 static void *print_to_port_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
-  Scheme_Object *obj, *port;
+  Scheme_Object *obj, *port, *depth;
 
   port = (Scheme_Object *)p->ku.k.p1;
   obj = (Scheme_Object *)p->ku.k.p2;
+  depth = (Scheme_Object *)p->ku.k.p3;
 
-  print_to_port(p->ku.k.i2 ? "write" : "display", 
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
+
+  print_to_port((p->ku.k.i2 
+                 ? ((p->ku.k.i2 = 2)
+                    ? "print"
+                    : "write")
+                 : "display"), 
 		obj, port,
-		p->ku.k.i2, p->ku.k.i1, p->ku.k.i3);
+		p->ku.k.i2, p->ku.k.i1, p->ku.k.i3,
+                depth);
 
   return NULL;
 }
@@ -232,7 +273,7 @@ static void do_handled_print(Scheme_Object *obj, Scheme_Object *port,
   } else
     a[1] = port;
   
-  scheme_apply_multi(scheme_write_proc, 2, a);
+  scheme_apply_multi(proc, 2, a);
   
   if (maxl > 0) {
     char *s;
@@ -258,6 +299,7 @@ void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
     p->ku.k.i1 = maxl;
     p->ku.k.i2 = 1;
     p->ku.k.i3 = 0;
+    p->ku.k.p3 = NULL;
     
     (void)scheme_top_level_do(print_to_port_k, 0);
   }
@@ -280,6 +322,7 @@ void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
     p->ku.k.i1 = maxl;
     p->ku.k.i2 = 0;
     p->ku.k.i3 = 0;
+    p->ku.k.p3 = NULL;
     
     (void)scheme_top_level_do(print_to_port_k, 0);
   }
@@ -300,8 +343,9 @@ void scheme_print_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
     p->ku.k.p1 = port;
     p->ku.k.p2 = obj;
     p->ku.k.i1 = maxl;
-    p->ku.k.i2 = 1;
+    p->ku.k.i2 = 2;
     p->ku.k.i3 = 1;
+    p->ku.k.p3 = NULL;
     
     (void)scheme_top_level_do(print_to_port_k, 0);
   }
@@ -315,7 +359,7 @@ void scheme_print(Scheme_Object *obj, Scheme_Object *port)
 static void *print_to_string_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
-  Scheme_Object *obj;
+  Scheme_Object *obj, *qq_depth;
   long *len, maxl;
   int iswrite, check_honu;
 
@@ -324,11 +368,13 @@ static void *print_to_string_k(void)
   maxl = p->ku.k.i1;
   iswrite = p->ku.k.i2;
   check_honu = p->ku.k.i3;
+  qq_depth = (Scheme_Object *)p->ku.k.p3;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
 
-  return (void *)print_to_string(obj, len, iswrite, NULL, maxl, check_honu);
+  return (void *)print_to_string(obj, len, iswrite, NULL, maxl, check_honu, qq_depth);
 }
 
 char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
@@ -340,6 +386,7 @@ char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
   p->ku.k.i1 = maxl;
   p->ku.k.i2 = 1;
   p->ku.k.i3 = 0;
+  p->ku.k.p3 = NULL;
 
   return (char *)scheme_top_level_do(print_to_string_k, 0);
 }
@@ -358,6 +405,7 @@ char *scheme_display_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
   p->ku.k.i1 = maxl;
   p->ku.k.i2 = 0;
   p->ku.k.i3 = 0;
+  p->ku.k.p3 = NULL;
 
   return (char *)scheme_top_level_do(print_to_string_k, 0);
 }
@@ -374,8 +422,9 @@ char *scheme_print_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
   p->ku.k.p1 = obj;
   p->ku.k.p2 = len;
   p->ku.k.i1 = maxl;
-  p->ku.k.i2 = 1;
+  p->ku.k.i2 = 2;
   p->ku.k.i3 = 1;
+  p->ku.k.p3 = NULL;
 
   return (char *)scheme_top_level_do(print_to_string_k, 0);
 }
@@ -388,19 +437,19 @@ char *scheme_print_to_string(Scheme_Object *obj, long *len)
 void
 scheme_internal_write(Scheme_Object *obj, Scheme_Object *port)
 {
-  print_to_port("write", obj, port, 1, -1, 0);
+  print_to_port("write", obj, port, 1, -1, 0, NULL);
 }
 
 void
 scheme_internal_display(Scheme_Object *obj, Scheme_Object *port)
 {
-  print_to_port("display", obj, port, 0, -1, 0);
+  print_to_port("display", obj, port, 0, -1, 0, NULL);
 }
 
 void
-scheme_internal_print(Scheme_Object *obj, Scheme_Object *port)
+scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Object *depth)
 {
-  print_to_port("print", obj, port, 1, -1, 1);
+  print_to_port("print", obj, port, 2, -1, 1, depth);
 }
 
 #ifdef DO_STACK_CHECK
@@ -834,7 +883,8 @@ static char *
 print_to_string(Scheme_Object *obj, 
 		long * volatile len, int write,
 		Scheme_Object *port, long maxl,
-		int check_honu)
+		int check_honu,
+                Scheme_Object *qq_depth)
 {
   Scheme_Hash_Table * volatile ht;
   Scheme_Object *v;
@@ -852,6 +902,7 @@ print_to_string(Scheme_Object *obj,
   params.print_maxlen = maxl;
   params.print_port = port;
   params.print_syntax = 0;
+  params.depth_delta = NULL;
 
   /* Getting print params can take a while, and they're irrelevant
      for simple things like displaying numbers. So try a shortcut: */
@@ -866,6 +917,7 @@ print_to_string(Scheme_Object *obj,
     params.print_vec_shorthand = 0;
     params.print_hash_table = 0;
     params.print_unreadable = 1;
+    params.print_reader = 1;
     params.print_pair_curly = 0;
     params.print_mpair_curly = 1;
     params.can_read_pipe_quote = 1;
@@ -904,6 +956,28 @@ print_to_string(Scheme_Object *obj,
     params.print_pair_curly = SCHEME_TRUEP(v);
     v = scheme_get_param(config, MZCONFIG_PRINT_MPAIR_CURLY);
     params.print_mpair_curly = SCHEME_TRUEP(v);
+    if (write > 1) {
+      v = scheme_get_param(config, MZCONFIG_PRINT_AS_QQ);
+      if (SCHEME_TRUEP(v)) {
+        params.depth_delta = scheme_make_integer(0);
+        if (qq_depth) {
+          if (scheme_bin_gt(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH))) {
+            write = 3 + REASONABLE_QQ_DEPTH;
+            qq_depth = scheme_bin_minus(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH));
+            params.depth_delta = qq_depth;
+          } else
+            write = 3 + SCHEME_INT_VAL(qq_depth);
+        } else
+          write = 3;
+      }
+    }
+    /* at this point, write >= 3  =>  qq printing at depth write - 3 */
+    if (write > 2) {
+      params.print_reader = 1;
+    } else {
+      v = scheme_get_param(config, MZCONFIG_PRINT_READER);
+      params.print_reader = SCHEME_TRUEP(v);
+    }
     v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE);
     params.can_read_pipe_quote = SCHEME_TRUEP(v);
     v = scheme_get_param(config, MZCONFIG_CASE_SENS);
@@ -957,7 +1031,8 @@ print_to_string(Scheme_Object *obj,
 }
 
 static void 
-print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdisplay, long maxl, int check_honu)
+print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdisplay, 
+              long maxl, int check_honu, Scheme_Object *qq_depth)
 {
   Scheme_Output_Port *op;
   char *str;
@@ -967,7 +1042,7 @@ print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdispla
   if (op->closed)
     scheme_raise_exn(MZEXN_FAIL, "%s: output port is closed", name);
 
-  str = print_to_string(obj, &len, notdisplay, port, maxl, check_honu);
+  str = print_to_string(obj, &len, notdisplay, port, maxl, check_honu, qq_depth);
 
   scheme_write_byte_string(str, len, port);
 }
@@ -1576,9 +1651,28 @@ static void always_scheme(PrintParams *pp, int reset)
   }
 }
 
+static int to_quoted(PrintParams *pp, int notdisplay, const char *quote)
+{
+  if (notdisplay == 3) {
+    print_utf8_string(pp, quote, 0, 1);
+    return notdisplay + 1;
+  } else
+    return notdisplay;
+}
+
+static int to_unquoted(PrintParams *pp, int notdisplay)
+{
+  while (notdisplay > 3) {
+    print_utf8_string(pp, ",", 0, 1);
+    --notdisplay;
+  }
+  return notdisplay;
+}
+
 static int
 print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
       Scheme_Marshal_Tables *mt, PrintParams *pp)
+  /* notdisplay >= 3 => print at qq depth notdisplay - 3 */
 {
   int closed = 0;
   int save_honu_mode;
@@ -1741,6 +1835,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 	} else {
 	  const char *s;
 
+          if (notdisplay >= 3) {
+            if (notdisplay == 4) {
+              if (SAME_OBJ(obj, unquote_symbol)
+                  || SAME_OBJ(obj, unquote_splicing_symbol))
+                print_utf8_string(pp, ",'", 0, 2);
+              else
+                notdisplay = to_quoted(pp, notdisplay, "'");
+            } else
+              notdisplay = to_quoted(pp, notdisplay, "'");
+          }
+	  
 	  if (is_kw)
 	    print_utf8_string(pp, "#:", 0, 2);
 	  s = scheme_symbol_name_and_size(obj, (unsigned int *)&l, 
@@ -1866,6 +1971,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
       if (compact) {
 	print_compact(pp, CPT_NULL);
       } else {
+        notdisplay = to_quoted(pp, notdisplay, "'");
 	if (pp->honu_mode)
 	  print_utf8_string(pp, "null", 0, 4);
 	else
@@ -1875,18 +1981,21 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
     }
   else if (SCHEME_PAIRP(obj))
     {
-      print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly);
+      notdisplay = to_quoted(pp, notdisplay, "`");
+      print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly, 0);
       closed = 1;
     }
   else if (SCHEME_MUTABLE_PAIRP(obj))
     {
+      notdisplay = to_quoted(pp, notdisplay, "`");
       if (compact || !pp->print_unreadable)
 	cannot_print(pp, notdisplay, obj, ht, compact);
-      print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly);
+      print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly, 0);
       closed = 1;
     }
   else if (SCHEME_CHAPERONE_VECTORP(obj))
     {
+      notdisplay = to_quoted(pp, notdisplay, "`");
       print_vector(obj, notdisplay, compact, ht, mt, pp, 0);
       closed = 1;
     }
@@ -1900,6 +2009,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 	  print_compact(pp, CPT_BOX);
 	else {
 	  always_scheme(pp, 1);
+          notdisplay = to_quoted(pp, notdisplay, "`");
 	  print_utf8_string(pp, "#&", 0, 2);
 	}
         if (SCHEME_BOXP(obj))
@@ -1933,6 +2043,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 	  print_compact_number(pp, 0);
       } else {
 	always_scheme(pp, 1);
+        notdisplay = to_quoted(pp, notdisplay, "`");
 	print_utf8_string(pp, "#hash", 0, 5);
         if (SCHEME_HASHTP(obj)) {
           if (!scheme_is_hash_table_equal(obj)) {
@@ -2061,10 +2172,18 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
           Scheme_Object *vec, *prefab;
           prefab = ((Scheme_Structure *)obj)->stype->prefab_key;
 	  vec = scheme_struct_to_vector(obj, NULL, pp->inspector);
+          if ((notdisplay >= 3) && !prefab) {
+            notdisplay = to_unquoted(pp, notdisplay);
+            vec = scheme_vector_to_list(vec);
+            vec = scheme_make_pair(scheme_object_name(obj), SCHEME_CDR(vec));
+            print_pair(vec, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly, 1);
+          } else {
             if (prefab) {
               SCHEME_VEC_ELS(vec)[0] = SCHEME_CDR(prefab);
+              notdisplay = to_quoted(pp, notdisplay, "`");
             }
             print_vector(vec, notdisplay, compact, ht, mt, pp, !!prefab);
+          }
 	  closed = 1;
 	} else {
 	  Scheme_Object *src;
@@ -2456,7 +2575,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
           char *str;
           print_utf8_string(pp, " ", 0, 1);
           str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx, 0, NULL),
-                                &slen, 1, NULL, pp->print_syntax, 0);
+                                &slen, 1, NULL, pp->print_syntax, 0, NULL);
           print_utf8_string(pp, str, 0, slen);
         }
         print_utf8_string(pp, ">", 0, 1);
@@ -3065,13 +3184,80 @@ print_byte_string(const char *str, int delta, int len, int notdisplay, PrintPara
   }
 }
 
+static int is_special_reader_form(PrintParams *pp, int notdisplay, Scheme_Object *p)
+{
+  Scheme_Object *v;
+
+  if (notdisplay && pp->print_reader) {
+    v = SCHEME_CAR(p);
+    p = SCHEME_CDR(p);
+    if (!SCHEME_PAIRP(p)) return 0;
+    p = SCHEME_CDR(p);
+    if (!SCHEME_NULLP(p)) return 0;
+    if (SCHEME_SYMBOLP(v)) {
+      if (SAME_OBJ(v, quote_symbol)
+          || SAME_OBJ(v, quasiquote_symbol)
+          || (SAME_OBJ(v, unquote_symbol) && (notdisplay != 4))
+          || (SAME_OBJ(v, unquote_splicing_symbol) && (notdisplay != 4))
+          || SAME_OBJ(v, syntax_symbol)
+          || SAME_OBJ(v, quasisyntax_symbol)
+          || SAME_OBJ(v, unsyntax_symbol)
+          || SAME_OBJ(v, unsyntax_splicing_symbol))
+        return 1;
+          
+    }
+  }
+  return 0;
+}
+
+static int print_special_reader_form(Scheme_Object *v, PrintParams *pp, int notdisplay)
+{
+  const char *str;
+  int len;
+
+  if (SAME_OBJ(v, quote_symbol)) {
+    str = "'";
+    len = 1;
+  } else if (SAME_OBJ(v, quasiquote_symbol)) {
+    str = "`";
+    len = 1;
+    notdisplay++;
+  } else if (SAME_OBJ(v, unquote_symbol)) {
+    str = ",";
+    len = 1;
+    --notdisplay;
+  } else if (SAME_OBJ(v, unquote_splicing_symbol)) {
+    str = ",@";
+    len = 2;
+    --notdisplay;
+  } else if (SAME_OBJ(v, syntax_symbol)) {
+    str = "#'";
+    len = 2;
+  } else if (SAME_OBJ(v, quasisyntax_symbol)) {
+    str = "#`";
+    len = 2;
+  } else if (SAME_OBJ(v, unsyntax_symbol)) {
+    str = "#,";
+    len = 2;
+  } else if (SAME_OBJ(v, unsyntax_splicing_symbol)) {
+    str = "#,@";
+    len = 3;
+  } else {
+    str = "???";
+    len = 3;
+  }
+
+  print_utf8_string(pp, str, 0, len);
+
+  return notdisplay;
+}
 
 static void
 print_pair(Scheme_Object *pair, int notdisplay, int compact, 
 	   Scheme_Hash_Table *ht, 
            Scheme_Marshal_Tables *mt, 
 	   PrintParams *pp,
-           Scheme_Type pair_type, int round_parens)
+           Scheme_Type pair_type, int round_parens, int first_unquoted)
 {
   Scheme_Object *cdr;
   int super_compact = 0;
@@ -3162,16 +3348,22 @@ print_pair(Scheme_Object *pair, int notdisplay, int compact,
     if (!super_compact)
       print_compact(pp, CPT_PAIR);
   } else {
-    if (round_parens)
+    if (round_parens) {
+      if (!first_unquoted && is_special_reader_form(pp, notdisplay, pair)) {
+        notdisplay = print_special_reader_form(SCHEME_CAR(pair), pp, notdisplay);
+        (void)print(SCHEME_CADR(pair), notdisplay, compact, ht, mt, pp);
+        return;
+      } else 
         print_utf8_string(pp,"(", 0, 1);
-    else
+    } else
       print_utf8_string(pp,"{", 0, 1);
   }
 
-  print(SCHEME_CAR(pair), notdisplay, compact, ht, mt, pp);
+  print(SCHEME_CAR(pair), (first_unquoted ? 1 : notdisplay), compact, ht, mt, pp);
 
-  cdr = SCHEME_CDR (pair);
+  cdr = SCHEME_CDR(pair);
-  while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
+  while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)
+         && !is_special_reader_form(pp, notdisplay, pair)) {
     if (ht && !super_compact) {
       if ((long)scheme_hash_get(ht, cdr) != 1) {
 	/* This needs a tag */
@@ -3450,7 +3642,9 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
   volatile long save_max;
 
   if (!SCHEME_OUTPORTP(argv[1])) {
-    scheme_wrong_type(notdisplay ? "write/recusrive" : "display/recursive",
+    scheme_wrong_type((notdisplay > 1)
+                      ? "print/recursive"
+                      : (notdisplay ? "write/recusrive" : "display/recursive"),
 		      "output-port", 1, argc, argv);
     return NULL;
   }
@@ -3491,6 +3685,29 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
 
 	pp->print_port = argv[1];
 
+        if (notdisplay > 1) {
+          if (argc > 2) {
+            Scheme_Object *qq_depth = argv[2];
+            if (!scheme_nonneg_exact_p(qq_depth))
+              scheme_wrong_type("print/recursive", "nonnegative exact integer", 2, argc, argv);
+            pp = copy_print_params(pp);
+            if (scheme_bin_gt(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH))) {
+              notdisplay = 3 + REASONABLE_QQ_DEPTH;
+              qq_depth = scheme_bin_minus(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH));
+              pp->depth_delta = qq_depth;
+            } else {
+              pp->depth_delta = scheme_make_integer(0);
+              notdisplay = 3 + SCHEME_INT_VAL(qq_depth);
+            }
+          } else if (pp->depth_delta) {
+            notdisplay = 3;
+            if (!SAME_OBJ(pp->depth_delta, scheme_make_integer(0))) {
+              pp = copy_print_params(pp);
+              pp->depth_delta = scheme_make_integer(0);
+            }
+          }
+        }
+
 	/* Recur */
 	print(argv[0], notdisplay, 0, ht, mt, pp);
 
@@ -3518,13 +3735,18 @@ static Scheme_Object *custom_display_recur(void *_vec, int argc, Scheme_Object *
   return custom_recur(0, _vec, argc, argv);
 }
 
+static Scheme_Object *custom_print_recur(void *_vec, int argc, Scheme_Object **argv)
+{
+  return custom_recur(2, _vec, argc, argv);
+}
+
 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
 				Scheme_Marshal_Tables *mt,
 				PrintParams *orig_pp, int notdisplay)
 {
   Scheme_Object *v, *a[3], *o, *vec, *orig_port;
   Scheme_Output_Port *op;
-  Scheme_Object *recur_write, *recur_display;
+  Scheme_Object *recur_write, *recur_display, *recur_print;
   PrintParams *pp;
 
   v = scheme_is_writable_struct(s);
@@ -3557,11 +3779,14 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
 						  vec,
 						  "custom-display-recur-handler",
 						  2, 2);
-
+  recur_print = scheme_make_closed_prim_w_arity(custom_print_recur,
+						vec,
+						"custom-print-recur-handler",
+						2, 3);
 
   op->write_handler = recur_write;
   op->display_handler = recur_display;
-  op->print_handler = recur_write;
+  op->print_handler = recur_print;
 
   /* First, flush print cache to actual port,
      so further writes go after current writes: */
@@ -3570,7 +3795,12 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
 
   a[0] = s;
   a[1] = o;
+  if (notdisplay >= 3) {
+    a[2] = scheme_bin_plus(pp->depth_delta, scheme_make_integer(notdisplay - 3));
+    pp->depth_delta = a[2];
+  } else
     a[2] = (notdisplay ? scheme_true : scheme_false);
+
   scheme_apply_multi(v, 3, a);
 
   scheme_close_output_port(o);

src/mzscheme/src/read.c

@@ -118,6 +118,8 @@ static Scheme_Object *print_pair_curly(int, Scheme_Object *[]);
 static Scheme_Object *print_mpair_curly(int, Scheme_Object *[]);
 static Scheme_Object *print_honu(int, Scheme_Object *[]);
 static Scheme_Object *print_syntax_width(int, Scheme_Object *[]);
+static Scheme_Object *print_reader(int, Scheme_Object *[]);
+static Scheme_Object *print_as_qq(int, Scheme_Object *[]);
 
 static int scheme_ellipses(mzchar* buffer, int length);
 
@@ -536,6 +538,8 @@ void scheme_init_read(Scheme_Env *env)
   GLOBAL_PARAMETER("print-mpair-curly-braces",      print_mpair_curly,      MZCONFIG_PRINT_MPAIR_CURLY,           env);
   GLOBAL_PARAMETER("print-honu",                    print_honu,             MZCONFIG_HONU_MODE,                   env);
   GLOBAL_PARAMETER("print-syntax-width",            print_syntax_width,     MZCONFIG_PRINT_SYNTAX_WIDTH,          env);
+  GLOBAL_PARAMETER("print-reader-abbreviations",    print_reader,           MZCONFIG_PRINT_READER,                env);
+  GLOBAL_PARAMETER("print-as-quasiquote",           print_as_qq,            MZCONFIG_PRINT_AS_QQ,                 env);
 
   GLOBAL_PRIM_W_ARITY("make-readtable",     make_readtable,     1, -1,      env);
   GLOBAL_FOLDING_PRIM("readtable?",         readtable_p,        1, 1, 1,    env);
@@ -753,6 +757,18 @@ print_honu(int argc, Scheme_Object *argv[])
   DO_CHAR_PARAM("print-honu", MZCONFIG_HONU_MODE);
 }
 
+static Scheme_Object *
+print_reader(int argc, Scheme_Object *argv[])
+{
+  DO_CHAR_PARAM("print-reader-abbreviations", MZCONFIG_PRINT_READER);
+}
+
+static Scheme_Object *
+print_as_qq(int argc, Scheme_Object *argv[])
+{
+  DO_CHAR_PARAM("print-as-quasiquote", MZCONFIG_PRINT_AS_QQ);
+}
+
 static Scheme_Object *good_syntax_width(int c, Scheme_Object **argv)
 {
   int ok;

src/mzscheme/src/schemef.h

@@ -699,8 +699,8 @@ MZ_EXTERN Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, in
 MZ_EXTERN Scheme_Object *scheme_read(Scheme_Object *port);
 MZ_EXTERN Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc);
 MZ_EXTERN void scheme_write(Scheme_Object *obj, Scheme_Object *port);
-MZ_EXTERN void scheme_display(Scheme_Object *obj, Scheme_Object *port);
 MZ_EXTERN void scheme_print(Scheme_Object *obj, Scheme_Object *port);
+MZ_EXTERN void scheme_display(Scheme_Object *obj, Scheme_Object *port);
 MZ_EXTERN void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
 MZ_EXTERN void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
 MZ_EXTERN void scheme_print_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
@@ -993,6 +993,15 @@ MZ_EXTERN Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
 						 Scheme_Object *uninit_val,
 						 Scheme_Object *properties,
 						 Scheme_Object *guard);
+MZ_EXTERN Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
+                                                  Scheme_Object *parent,
+                                                  Scheme_Object *inspector,
+                                                  int num_fields, int num_uninit_fields,
+                                                  Scheme_Object *uninit_val,
+                                                  Scheme_Object *proc_attr,
+                                                  Scheme_Object *properties,
+                                                  char *immutable_array,
+                                                  Scheme_Object *guard);
 MZ_EXTERN Scheme_Object *scheme_make_struct_instance(Scheme_Object *stype,
 						     int argc,
 						     Scheme_Object **argv);

src/mzscheme/src/schemex.h

@@ -577,8 +577,8 @@ Scheme_Object *(*scheme_compile)(Scheme_Object *form, Scheme_Env *env, int write
 Scheme_Object *(*scheme_read)(Scheme_Object *port);
 Scheme_Object *(*scheme_read_syntax)(Scheme_Object *port, Scheme_Object *stxsrc);
 void (*scheme_write)(Scheme_Object *obj, Scheme_Object *port);
-void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port);
 void (*scheme_print)(Scheme_Object *obj, Scheme_Object *port);
+void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port);
 void (*scheme_write_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
 void (*scheme_display_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
 void (*scheme_print_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
@@ -825,6 +825,15 @@ Scheme_Object *(*scheme_make_struct_type)(Scheme_Object *base,
 						 Scheme_Object *uninit_val,
 						 Scheme_Object *properties,
 						 Scheme_Object *guard);
+Scheme_Object *(*scheme_make_struct_type2)(Scheme_Object *base,
+                                                  Scheme_Object *parent,
+                                                  Scheme_Object *inspector,
+                                                  int num_fields, int num_uninit_fields,
+                                                  Scheme_Object *uninit_val,
+                                                  Scheme_Object *proc_attr,
+                                                  Scheme_Object *properties,
+                                                  char *immutable_array,
+                                                  Scheme_Object *guard);
 Scheme_Object *(*scheme_make_struct_instance)(Scheme_Object *stype,
 						     int argc,
 						     Scheme_Object **argv);

src/mzscheme/src/schemex.inc

@@ -403,8 +403,8 @@
   scheme_extension_table->scheme_read = scheme_read;
   scheme_extension_table->scheme_read_syntax = scheme_read_syntax;
   scheme_extension_table->scheme_write = scheme_write;
-  scheme_extension_table->scheme_display = scheme_display;
   scheme_extension_table->scheme_print = scheme_print;
+  scheme_extension_table->scheme_display = scheme_display;
   scheme_extension_table->scheme_write_w_max = scheme_write_w_max;
   scheme_extension_table->scheme_display_w_max = scheme_display_w_max;
   scheme_extension_table->scheme_print_w_max = scheme_print_w_max;
@@ -575,6 +575,7 @@
   scheme_extension_table->scheme_make_struct_values = scheme_make_struct_values;
   scheme_extension_table->scheme_make_struct_names = scheme_make_struct_names;
   scheme_extension_table->scheme_make_struct_type = scheme_make_struct_type;
+  scheme_extension_table->scheme_make_struct_type2 = scheme_make_struct_type2;
   scheme_extension_table->scheme_make_struct_instance = scheme_make_struct_instance;
   scheme_extension_table->scheme_is_struct_instance = scheme_is_struct_instance;
   scheme_extension_table->scheme_struct_ref = scheme_struct_ref;

src/mzscheme/src/schemexm.h

@@ -403,8 +403,8 @@
 #define scheme_read (scheme_extension_table->scheme_read)
 #define scheme_read_syntax (scheme_extension_table->scheme_read_syntax)
 #define scheme_write (scheme_extension_table->scheme_write)
-#define scheme_display (scheme_extension_table->scheme_display)
 #define scheme_print (scheme_extension_table->scheme_print)
+#define scheme_display (scheme_extension_table->scheme_display)
 #define scheme_write_w_max (scheme_extension_table->scheme_write_w_max)
 #define scheme_display_w_max (scheme_extension_table->scheme_display_w_max)
 #define scheme_print_w_max (scheme_extension_table->scheme_print_w_max)
@@ -575,6 +575,7 @@
 #define scheme_make_struct_values (scheme_extension_table->scheme_make_struct_values)
 #define scheme_make_struct_names (scheme_extension_table->scheme_make_struct_names)
 #define scheme_make_struct_type (scheme_extension_table->scheme_make_struct_type)
+#define scheme_make_struct_type2 (scheme_extension_table->scheme_make_struct_type2)
 #define scheme_make_struct_instance (scheme_extension_table->scheme_make_struct_instance)
 #define scheme_is_struct_instance (scheme_extension_table->scheme_is_struct_instance)
 #define scheme_struct_ref (scheme_extension_table->scheme_struct_ref)

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 978
+#define EXPECTED_PRIM_COUNT 980
 #define EXPECTED_UNSAFE_COUNT 65
 #define EXPECTED_FLFXNUM_COUNT 53
 

src/mzscheme/src/schpriv.h

@@ -708,19 +708,13 @@ Scheme_Object *scheme_make_struct_type_from_string(const char *base,
 						   Scheme_Object *props,
 						   Scheme_Object *guard,
 						   int immutable);
-Scheme_Object *scheme_make_proc_struct_type(Scheme_Object *base,
-                                            Scheme_Object *parent,
-                                            Scheme_Object *inspector,
-                                            int num_fields, int num_uninit,
-                                            Scheme_Object *uninit_val,
-                                            Scheme_Object *proc_attr,
-                                            Scheme_Object *guard);
 
 Scheme_Object *scheme_struct_to_vector(Scheme_Object *_s, Scheme_Object *unknown_val, Scheme_Object *insp);
 
 Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method);
 
 Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a);
+Scheme_Object *scheme_object_name(Scheme_Object *a);
 
 Scheme_Object *scheme_is_writable_struct(Scheme_Object *s);
 
@@ -1914,7 +1908,7 @@ Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc,
                                     Scheme_Object *delay_load_info);
 void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port);
 void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port);
-void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port);
+void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Object *quote_depth);
 
 Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok);
 

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.2.5.4"
+#define MZSCHEME_VERSION "4.2.5.5"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 5
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 5
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/mzscheme/src/struct.c

@@ -171,11 +171,11 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type);
 #define icons scheme_make_pair
 #define _intern scheme_intern_symbol
 
-#define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET
+#define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME
-#define LOC_STRUCT_FLAGS BUILTIN_STRUCT_FLAGS | SCHEME_STRUCT_NO_SET
 
 #define TYPE_NAME(base, blen) make_name("struct:", base, blen, "", NULL, 0, "", 1)
-#define CSTR_NAME(base, blen) make_name("make-", base, blen, "", NULL, 0, "", 1)
+#define CSTR_NAME(base, blen) make_name("", base, blen, "", NULL, 0, "", 1)
+#define CSTR_MAKE_NAME(base, blen) make_name("make-", base, blen, "", NULL, 0, "", 1)
 #define PRED_NAME(base, blen) make_name("", base, blen, "?", NULL, 0, "", 1)
 #define GET_NAME(base, blen, field, flen, sym) make_name("", base, blen, "-", field, flen, "", sym)
 #define SET_NAME(base, blen, field, flen, sym) make_name("set-", base, blen, "-", field, flen, "!", sym)
@@ -259,10 +259,10 @@ scheme_init_struct (Scheme_Env *env)
   
   loc_names = scheme_make_struct_names_from_array("srcloc",
 						  5, location_fields,
-						  LOC_STRUCT_FLAGS, &loc_count);
+						  BUILTIN_STRUCT_FLAGS, &loc_count);
   
   loc_values = scheme_make_struct_values(location_struct, loc_names, loc_count, 
-					 LOC_STRUCT_FLAGS);
+					 BUILTIN_STRUCT_FLAGS);
   for (i = 0; i < loc_count - 1; i++) {
     scheme_add_global_constant(scheme_symbol_val(loc_names[i]), loc_values[i], 
 			       env);
@@ -405,7 +405,7 @@ scheme_init_struct (Scheme_Env *env)
   REGISTER_SO(scheme_make_struct_type_proc);
   scheme_make_struct_type_proc = scheme_make_prim_w_arity2(make_struct_type,
                                                            "make-struct-type",
-                                                           4, 10,
+                                                           4, 11,
                                                            5, 5);
 
   scheme_add_global_constant("make-struct-type", 
@@ -504,7 +504,7 @@ scheme_init_struct (Scheme_Env *env)
   scheme_add_global_constant("struct-type-make-constructor",
 			     scheme_make_prim_w_arity(struct_type_constr,
 						      "struct-type-make-constructor",
-						      1, 1),
+						      1, 2),
 			     env);
   scheme_add_global_constant("struct->vector",
 			     scheme_make_prim_w_arity(struct_to_vector,
@@ -1530,6 +1530,8 @@ int scheme_is_set_transformer(Scheme_Object *o)
 }
 
 static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } 
+static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o)
+                                                                          || scheme_check_proc_arity(NULL, 2, -1, 0, &o))); }
 
 Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
 {
@@ -1537,6 +1539,14 @@ Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
   return NULL;
 }
 
+static Scheme_Object *chain_transformer(void *data, int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *a[2], *v = (Scheme_Object *)data;
+  a[0] = SCHEME_CAR(v);
+  a[1] = argv[0];
+  return _scheme_tail_apply(SCHEME_CDR(v), 2, a);
+}
+
 Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
 {
   if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
@@ -1551,6 +1561,11 @@ Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
                                      "bad-syntax-set!-transformer",
                                      1, 1);
       }
+    } else if (!scheme_check_proc_arity(NULL, 1, -1, 0, &v)) {
+      /* Must be a procedure of 2 arguments. Reduce to a procedure of 1. */
+      o = scheme_make_pair(o, v);
+      v = scheme_make_closed_prim_w_arity(chain_transformer, (void *)o,
+                                          "set!-transformer", 1, 1);
     }
     return v;
   }
@@ -1560,8 +1575,8 @@ Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
 static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[])
 {
   return check_indirect_property_value_ok("guard-for-prop:set!-transformer", 
-                                          is_proc_1, 
+                                          is_proc_1_or_2, 
-                                          "property value is not an procedure (arity 1) or exact non-negative integer: ",
+                                          "property value is not an procedure (arity 1 or 2) or exact non-negative integer: ",
                                           argc, argv);
 }
 
@@ -2485,9 +2500,17 @@ static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[])
   else
     stype = (Scheme_Struct_Type *)argv[0];
 
+  if ((argc < 2) || SCHEME_FALSEP(argv[1]))
+    v = CSTR_MAKE_NAME(scheme_symbol_val(stype->name), SCHEME_SYM_LEN(stype->name));
+  else if (SCHEME_SYMBOLP(argv[1]))
+    v = argv[1];
+  else {
+    scheme_wrong_type("struct-type-make-constructor", "symbol", 1, argc, argv);
+    return NULL;
+  }
+  
   v = make_struct_proc(stype, 
-                       scheme_symbol_val(CSTR_NAME(scheme_symbol_val(stype->name),
+                       scheme_symbol_val(v),
-                                                   SCHEME_SYM_LEN(stype->name))),
                        SCHEME_CONSTR,
                        stype->num_slots);
 
@@ -3200,7 +3223,10 @@ static Scheme_Object **_make_struct_names(const char *base, int blen,
   }
   if (!(flags & SCHEME_STRUCT_NO_CONSTR)) {
     Scheme_Object *nm;
+    if (flags & SCHEME_STRUCT_NO_MAKE_PREFIX)
       nm = CSTR_NAME(base, blen);
+    else
+      nm = CSTR_MAKE_NAME(base, blen);
     names[pos++] = nm;
   }
   if (!(flags & SCHEME_STRUCT_NO_PRED)) {
@@ -3711,7 +3737,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
       p = SCHEME_INT_VAL(proc_attr);
       if (p < ni) {
         if (!immutable_array) {
-          immutable_array= (char *)scheme_malloc_atomic(n);
+          immutable_array = (char *)scheme_malloc_atomic(n);
           memset(immutable_array, 0, n);
         }
         immutable_array[p] = 1;
@@ -3911,19 +3937,21 @@ Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
 			   guard);
 }
 
-Scheme_Object *scheme_make_proc_struct_type(Scheme_Object *base,
+Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
                                         Scheme_Object *parent,
                                         Scheme_Object *inspector,
                                         int num_fields, int num_uninit,
                                         Scheme_Object *uninit_val,
+                                        Scheme_Object *properties,
                                         Scheme_Object *proc_attr,
+                                        char *immutable_array,
                                         Scheme_Object *guard)
 {
   return _make_struct_type(base,
 			   parent, inspector, 
 			   num_fields, num_uninit,
-			   uninit_val, scheme_null, 
+			   uninit_val, properties, 
-			   proc_attr, NULL,
+			   proc_attr, immutable_array,
 			   guard);
 }
 
@@ -4045,7 +4073,7 @@ static char* immutable_pos_list_to_immutable_array(Scheme_Object *immutable_pos_
 static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
 {
   int initc, uninitc, num_props = 0, prefab = 0;
-  Scheme_Object *props = scheme_null, *l, *a, **r;
+  Scheme_Object *props = scheme_null, *l, *a, **r, *cstr_name = NULL;
   Scheme_Object *inspector = NULL, *uninit_val;
   Scheme_Struct_Type *type;
   Scheme_Object *proc_attr = NULL, *immutable_pos_list = scheme_null, *guard = NULL;
@@ -4133,6 +4161,14 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
 		if (!SCHEME_PROCP(guard))
 		  scheme_wrong_type("make-struct-type", "procedure or #f", 9, argc, argv);
 	      }
+
+              if (argc > 10) {
+                if (!SCHEME_FALSEP(argv[10])) {
+                  if (!SCHEME_SYMBOLP(argv[10]))
+                    scheme_wrong_type("make-struct-type", "symbol or #f", 10, argc, argv);
+                  cstr_name = argv[10];
+                }
+              }
 	    }
 	  }
 	}
@@ -4177,8 +4213,7 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
                                           initc, uninitc,
                                           uninit_val,
                                           immutable_array);
-  }
+  } else {
-  else {
     type = (Scheme_Struct_Type *)_make_struct_type(argv[0],
                                                    SCHEME_FALSEP(argv[1]) ? NULL : argv[1],
                                                    inspector,
@@ -4188,6 +4223,7 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
                                                    immutable_array,
                                                    guard);
   }
+
   {
     int i;
     Scheme_Object **names;
@@ -4196,6 +4232,8 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
                                      NULL,
                                      SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET, 
                                      &i);
+    if (cstr_name)
+      names[1] = cstr_name;
     r = scheme_make_struct_values((Scheme_Object *)type, names, i, 
                                   SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET);
 

src/mzscheme/src/thread.c

@@ -6624,6 +6624,8 @@ static void make_initial_config(Scheme_Thread *p)
   init_param(cells, paramz, MZCONFIG_PRINT_UNREADABLE, scheme_true);
   init_param(cells, paramz, MZCONFIG_PRINT_PAIR_CURLY, scheme_false);
   init_param(cells, paramz, MZCONFIG_PRINT_MPAIR_CURLY, scheme_true);
+  init_param(cells, paramz, MZCONFIG_PRINT_READER, scheme_false);
+  init_param(cells, paramz, MZCONFIG_PRINT_AS_QQ, scheme_false);
   init_param(cells, paramz, MZCONFIG_PRINT_SYNTAX_WIDTH, scheme_make_integer(32));
 
   init_param(cells, paramz, MZCONFIG_HONU_MODE, scheme_false);