added pretty-print-parameters to control how pretty printing happens for terms

collects/redex/gui.rkt

@@ -103,6 +103,7 @@
  [default-pretty-printer
    (-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%) 
        void?)]
+ [pretty-print-parameters (parameter/c (-> (-> any) any))]
  [current-pretty-printer
   (parameter/c 
    (-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%) 

collects/redex/private/sexp-diffs.rkt

@@ -4,7 +4,8 @@
          mrlib/graph
          scheme/pretty
          scheme/class
-         framework)
+         framework
+         "size-snip.rkt")
 
 (provide show-differences find-differences)
 
@@ -90,8 +91,10 @@
 ;; render-sexp/colors : sexp ht text -> void
 (define (render-sexp/colors sexp to-color text columns)
   (let ([start '()])
-    (parameterize ([pretty-print-columns columns])
+    ((pretty-print-parameters)
-      (pretty-print sexp (open-output-text-editor text)))
+     (λ ()
+       (parameterize ([pretty-print-columns columns])
+         (pretty-print sexp (open-output-text-editor text)))))
     (for-each 
      (λ (p) (send text highlight-range (car p) (cdr p) (send the-color-database find-color "NavajoWhite")))
      to-color)
@@ -121,32 +124,34 @@
                                      (set! pending-bytes (bytes))))
                                  1]))
                             void)])
-    (parameterize ([pretty-print-columns columns]
+    ((pretty-print-parameters)
-                   [pretty-print-remap-stylable
+     (λ ()
-                    (λ (val)
+       (parameterize ([pretty-print-columns columns]
-                      (and (wrap? val)
+                      [pretty-print-remap-stylable
-                           (symbol? (wrap-content val))
+                       (λ (val)
-                           (wrap-content val)))]
+                         (and (wrap? val)
-                   [pretty-print-size-hook
+                              (symbol? (wrap-content val))
-                    (λ (val dsp? port)
+                              (wrap-content val)))]
-                      (if (wrap? val)
+                      [pretty-print-size-hook
-                          (string-length (format "~s" (wrap-content val)))
+                       (λ (val dsp? port)
-                          #f))]
+                         (if (wrap? val)
-                   [pretty-print-print-hook
+                             (string-length (format "~s" (wrap-content val)))
-                    (λ (val dsp? port)
+                             #f))]
-                      (write (wrap-content val) port))]
+                      [pretty-print-print-hook
-                   [pretty-print-pre-print-hook
+                       (λ (val dsp? port)
-                    (λ (obj port)
+                         (write (wrap-content val) port))]
-                      (when (hash-ref diff-ht obj #f)
+                      [pretty-print-pre-print-hook
-                        (flush-output port)
+                       (λ (obj port)
-                        (set! start (cons position start))))]
+                         (when (hash-ref diff-ht obj #f)
-                   [pretty-print-post-print-hook
+                           (flush-output port)
-                    (λ (obj port)
+                           (set! start (cons position start))))]
-                      (when (hash-ref diff-ht obj #f)
+                      [pretty-print-post-print-hook
-                        (flush-output port)
+                       (λ (obj port)
-                        (set! to-color (cons (cons (car start) position) to-color))
+                         (when (hash-ref diff-ht obj #f)
-                        (set! start (cdr start))))])
+                           (flush-output port)
-      (pretty-print sexp counting-port))
+                           (set! to-color (cons (cons (car start) position) to-color))
+                           (set! start (cdr start))))])
+         (pretty-print sexp counting-port))))
     to-color))
 
 ;; does a map-like operation, but if the list is dotted, flattens the results into an actual list.

collects/redex/private/size-snip.rkt

@@ -10,6 +10,7 @@
          size-text%
          default-pretty-printer
          current-pretty-printer
+         pretty-print-parameters
          initial-char-width
          resizing-pasteboard-mixin
          get-user-char-width)
@@ -22,6 +23,8 @@
     [(number? cw/proc) cw/proc]
     [else (cw/proc expr)]))
 
+(define pretty-print-parameters (make-parameter (λ (thunk) (thunk))))
+  
 (define (default-pretty-printer v port w spec)
   (parameterize ([pretty-print-columns w]
                  [pretty-print-size-hook
@@ -37,7 +40,9 @@
                        (display "hole" op)]
                       [(eq? val 'hole) 
                        (display ",'hole" op)]))])
-    (pretty-print v port)))
+    ((pretty-print-parameters)
+     (λ ()
+       (pretty-print v port)))))
 
 (define current-pretty-printer (make-parameter default-pretty-printer))
 

collects/redex/redex.scrbl

@@ -1748,6 +1748,17 @@ the color used to fill the arrowhead and the text colors control the
 color used to draw the label on the edge.
 }
 
+@defparam[pretty-print-parameters f (-> (-> any/c) any/c)]{
+  A parameter that is used to set other @racket[pretty-print]
+  parameters. 
+  
+  Specifically, whenever @racket[default-pretty-printer] prints
+  something it calls @racket[f] with a thunk that does the actual
+  printing. Thus, @racket[f] can adjust @racket[pretty-print]'s
+  parameters to adjust how printing happens.
+
+}
+                                                                       
 @defparam[current-pretty-printer pp (-> any/c
                                         output-port?
                                         exact-nonnegative-integer?
@@ -1761,7 +1772,9 @@ color used to draw the label on the edge.
 
 This is the default value of @racket[pp] used by @racket[traces] and
 @racket[stepper] and it uses
-@racket[pretty-print].
+@racket[pretty-print]. 
+
+This function uses the value of @racket[pretty-print-parameters] to adjust how it prints.
 
 It sets the @racket[pretty-print-columns] parameter to
 @racket[width], and it sets @racket[pretty-print-size-hook]