Make TR debug printer work again.

collects/tests/typed-racket/tr-random-testing.rkt

@@ -105,7 +105,6 @@
 (define (get-type e [typecheck (compose tc-expr expand)])
   (parameterize ([delay-errors? #f]
                  [current-namespace (namespace-anchor->namespace anch)]
-                 [custom-printer #t]
                  [infer-param infer]
                  [orig-module-stx (quote-syntax e)])
     (typecheck (datum->syntax #'here e))))

collects/tests/typed-racket/unit-tests/typecheck-tests.rkt

@@ -74,7 +74,6 @@
     [(_ e)
      #`(parameterize ([delay-errors? #f]
                       [current-namespace (namespace-anchor->namespace anch)]
-                      [custom-printer #t]
                       [infer-param infer]
                       [orig-module-stx (quote-syntax e)])
          (let ([ex (expand 'e)])
@@ -86,7 +85,6 @@
     [(_ e)
      #`(parameterize ([delay-errors? #f]
                       [current-namespace (namespace-anchor->namespace anch)]
-                      [custom-printer #t]
                       [infer-param infer]
                       [orig-module-stx (quote-syntax e)])
          (let ([ex (expand 'e)])

collects/typed-racket/core.rkt

@@ -6,7 +6,7 @@
          (private with-types type-contract parse-type)
          (except-in syntax/parse id)
          racket/match racket/syntax unstable/match racket/list syntax/stx
-         (types utils abbrev generalize)
+         (types utils abbrev generalize printer)
          (typecheck provide-handling tc-toplevel tc-app-helper)
          (rep type-rep)
          (env env-req)

collects/typed-racket/types/printer.rkt

@@ -5,9 +5,23 @@
          (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt"
                   "rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt"
                   "utils/utils.rkt"
-                  "utils/tc-utils.rkt"))
+                  "utils/tc-utils.rkt")
+         (for-syntax racket/base))
 
-(provide print-type print-filter print-object print-pathelem)
+;; printer-type: (one-of/c 'custom 'debug)
+(define-for-syntax printer-type 'custom)
+
+(define-syntax (make-provides stx)
+  (if (eq? printer-type 'debug)
+      #'(provide (rename-out
+                   (debug-printer print-type)
+                   (debug-printer print-filter)
+                   (debug-printer print-object)
+                   (debug-printer print-pathelem)))
+      #'(provide print-type print-filter print-object print-pathelem)))
+(make-provides)
+
+(provide print-multi-line-case-> special-dots-printing? print-complex-filters?)
 
 ;;TODO try to remove requirement on abbrev once promise is fixed
 
@@ -17,9 +31,9 @@
 ;; do we use simple type aliases in printing
 (define print-aliases #t)
 
+(define print-multi-line-case-> (make-parameter #f))
 (define special-dots-printing? (make-parameter #f))
 (define print-complex-filters? (make-parameter #f))
-(provide special-dots-printing? print-complex-filters?)
 
 ;; does t have a type name associated with it currently?
 ;; has-name : Type -> Maybe[Symbol]
@@ -309,3 +323,37 @@
     [else (fp "(Unknown Type: ~a)" (struct->vector c))]
     ))
 
+
+
+(define-syntax (make-debug-printer stx)
+  (syntax-local-introduce
+    (if (eq? printer-type 'debug)
+      #'(begin
+          (require racket/pretty)
+          (require mzlib/pconvert)
+
+          (define (converter v basic sub)
+            (define (gen-constructor sym)
+              (string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
+            (match v
+              [(? (lambda (e) (or (Filter? e)
+                                  (Object? e)
+                                  (PathElem? e)))
+                  (app (lambda (v) (vector->list (struct->vector v)))
+                       (list-rest tag seq fv fi stx vals)))
+               `(,(gen-constructor tag) ,@(map sub vals))]
+              [(? Type?
+                  (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx key vals)))
+               `(,(gen-constructor tag) ,@(map sub vals))]
+              [_ (basic v)]))
+
+          (define (debug-printer v port write?)
+            ((if write?
+                 pretty-write
+                 pretty-print)
+             (parameterize ((current-print-convert-hook converter))
+               (print-convert v))
+             port)))
+      #'(begin))))
+(make-debug-printer)
+

collects/typed-racket/utils/utils.rkt

@@ -21,7 +21,7 @@ at least theoretically.
  ;; logging
  printf/log show-input?
  ;; struct printing
- print-multi-line-case-> define-struct/printer
+ define-struct/printer
  ;; provide macros
  rep utils typecheck infer env private types)
 
@@ -109,9 +109,6 @@ at least theoretically.
 	 #'(log-debug (format fmt . args))])
       #'(void)))
 
-;; custom printing
-(define-for-syntax custom-printer #t)
-(define print-multi-line-case-> (make-parameter #f))
 
 (define-syntax (define-struct/printer stx)
   (syntax-parse stx
@@ -120,11 +117,9 @@ at least theoretically.
          #:property prop:custom-print-quotable 'never
          ;; Eta expansion so that printer is not evaluated
          ;; until needed.
-         #,@(if custom-printer
+         #:methods gen:custom-write
-              #'(#:methods gen:custom-write
+         [(define (write-proc v port write?)
-                 [(define (write-proc v port write?)
+            (printer v port write?))]
-                    (printer v port write?))])
-              #'())
          #:transparent)]))