From 3803b4e045764ee7d024b7f889e5dc7799194bb2 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 19 Mar 2007 03:29:06 +0000
Subject: [PATCH] fix pretty-printer to pay attention to print-box (PR 8567)

svn: r5787
---
 collects/mzlib/pretty.ss          | 24 ++++++++++++++----------
 collects/tests/mzscheme/pretty.ss | 14 ++++++++++++++
 2 files changed, 28 insertions(+), 10 deletions(-)

diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss
index bfb59e0aea..f1bdb78212 100644
--- a/collects/mzlib/pretty.ss
+++ b/collects/mzlib/pretty.ss
@@ -197,7 +197,7 @@
 							print-hook
 							(pretty-print-print-line))
 				    (print-graph) (print-struct) (print-hash-table)
-				    (and (not display?) (print-vector-length))
+				    (and (not display?) (print-vector-length)) (print-box)
 				    (pretty-print-depth)
 				    (lambda (o display?)
 				      (size-hook o display? port)))
@@ -369,7 +369,7 @@
 	     (write-string "        " port 0 n))))
 
    (define (generic-write obj display? width pport
-			  print-graph? print-struct? print-hash-table? print-vec-length?
+			  print-graph? print-struct? print-hash-table? print-vec-length? print-box?
 			  depth size-hook)
      
      (define table (make-hash-table)) ; Hash table for looking for loops
@@ -412,7 +412,8 @@
 	   (let loop ([obj obj])
 	     (and (or (vector? obj)
 		      (pair? obj)
-		      (box? obj)
+		      (and (box? obj)
+                           print-box?)
 		      (and (custom-write? obj)
 			   (not (struct-type? obj)))
 		      (and (struct? obj) print-struct?)
@@ -432,7 +433,7 @@
 				[(pair? obj)
 				 (or (loop (car obj))
 				     (loop (cdr obj)))]
-				[(box? obj) (loop (unbox obj))]
+				[(and (box? obj) print-box?) (loop (unbox obj))]
 				[(and (custom-write? obj)
 				      (not (struct-type? obj)))
 				 (loop (extract-sub-objects obj pport))]
@@ -456,7 +457,8 @@
 	 (let loop ([obj obj])
 	   (if (or (vector? obj)
 		   (pair? obj)
-		   (box? obj)
+		   (and (box? obj)
+                        print-box?)
 		   (and (custom-write? obj)
 			(not (struct-type? obj)))
 		   (and (struct? obj) print-struct?)
@@ -477,7 +479,7 @@
 			  [(pair? obj)
 			   (loop (car obj))
 			   (loop (cdr obj))]
-			  [(box? obj) (loop (unbox obj))]
+			  [(and (box? obj) print-box?) (loop (unbox obj))]
 			  [(and (custom-write? obj)
 				(not (struct-type? obj)))
 			   (loop (extract-sub-objects obj pport))]
@@ -639,7 +641,8 @@
 		(when print-vec-length?
 		  (out (number->string (vector-length obj))))
 		(wr-lst (vector->repeatless-list obj) #f depth)))]
-	    [(box? obj)        
+	    [(and (box? obj)
+                  print-box?)
 	     (check-expr-found
 	      obj pport #t
 	      #f #f
@@ -726,8 +729,9 @@
 	 ;; may have to split on multiple lines
 	 (let* ([can-multi (and width
                                 (not (size-hook obj display?))
-				(or (pair? obj) (vector? obj) 
-				    (box? obj) 
+				(or (pair? obj)
+                                    (vector? obj) 
+				    (and (box? obj) print-box?)
 				    (and (custom-write? obj)
 					 (not (struct-type? obj)))
 				    (and (struct? obj) print-struct?)
@@ -781,7 +785,7 @@
                                     "#hash"
                                     "#hasheq"))
 			   (pp-list (hash-table-map obj cons) extra pp-expr #f depth)]
-			  [(box? obj)
+			  [(and (box? obj) print-box?)
 			   (out "#&") 
 			   (pr (unbox obj) extra pp-pair depth)])
 			 (post-print pport obj)))))
diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss
index 7658812a14..a173caed6b 100644
--- a/collects/tests/mzscheme/pretty.ss
+++ b/collects/tests/mzscheme/pretty.ss
@@ -67,6 +67,20 @@
 (test ",@a" pp-string ',@a)
 (test "#'a" pp-string '#'a)
 (test "W{1 2}" pp-string (make-pprec 1 2))
+(test "#&10" pp-string (box 10))
+(parameterize ([print-box #f])
+  (test "#<box>" pp-string (box 10)))
+(test "#1(10)" pp-string (vector 10))
+(test "#2(10)" pp-string (vector 10 10))
+(parameterize ([print-vector-length #f])
+  (test "#(10 10)" pp-string (vector 10 10)))
+(test "#<hash-table>" pp-string (let ([ht (make-hash-table)])
+                                  (hash-table-put! ht 1 2)
+                                  ht))
+(parameterize ([print-hash-table #t])
+  (test "#hasheq((1 . 2))" pp-string (let ([ht (make-hash-table)])
+                                       (hash-table-put! ht 1 2)
+                                       ht)))
 
 (test #t pretty-print-style-table? (pretty-print-current-style-table))
 (test #t pretty-print-style-table? (pretty-print-extend-style-table #f null null))