Ported more code to new contract tools.

svn: r17733

collects/drscheme/private/debug.ss

@@ -335,8 +335,10 @@ profile todo:
   
   ;; =User=
   (define (print-planet-icon-to-stderr exn)
-    (when (exn:fail:contract2? exn)
+    (when (exn:fail:contract:blame? exn)
-      (let ([table (parse-gp exn (guilty-party exn))])
+      (let ([table (parse-gp exn
+                             (blame-guilty
+                              (exn:fail:contract:blame-object exn)))])
         (when table
           (let ([gp-url (bug-info->ticket-url table)])
             (when planet-note%

collects/drscheme/private/tools.ss

@@ -4,6 +4,7 @@
          scheme/list
          scheme/runtime-path
          scheme/contract
+         unstable/location
          setup/getinfo
          mred
          framework
@@ -326,7 +327,8 @@
                                                 name 
                                                 'drscheme 
                                                 tool-name
-                                                (quote-syntax name))]))
+                                                (quote name)
+                                                (quote-srcloc name))]))
                           name
                           ctc)
                 body)]

collects/mzlib/private/contract-arrow.ss

@@ -33,7 +33,7 @@
            (let ([proj-x (contract-projection rngs-x)] ...)
              (simple-contract
               #:name
-              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
+              (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
               #:projection
               (λ (blame)
                 (let ([p-app-x (proj-x blame)] ...)

collects/mzlib/private/contract-define.ss

@@ -2,9 +2,11 @@
 
 (provide define/contract)
 
-(require (for-syntax scheme/base)
+(require (for-syntax scheme/base
+                     unstable/srcloc
+                     (prefix-in a: scheme/contract/private/helpers))
          (only-in scheme/contract contract)
-         (for-syntax (prefix-in a: scheme/contract/private/helpers)))
+         unstable/location)
 
 ;; First, we have the old define/contract implementation, which
 ;; is still used in mzlib/contract.
@@ -12,7 +14,7 @@
 (define-for-syntax (make-define/contract-transformer contract-id id)
   (make-set!-transformer
    (λ (stx)
-     (with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
+     (with-syntax ([neg-blame-str (source-location->string stx)]
                    [contract-id contract-id]
                    [id id])
        (syntax-case stx (set!)
@@ -27,7 +29,8 @@
                        id
                        (syntax->datum (quote-syntax f))
                        neg-blame-str
-                       (quote-syntax f))
+                       (quote f)
+                       (quote-srcloc f))
              arg
              ...))]
          [ident
@@ -37,7 +40,8 @@
                       id
                       (syntax->datum (quote-syntax ident))
                       neg-blame-str
-                      (quote-syntax ident)))])))))
+                      (quote ident)
+                      (quote-srcloc ident)))])))))
 
 ;; (define/contract id contract expr)
 ;; defines `id' with `contract'; initially binding

collects/syntax/private/stxparse/lib.ss

@@ -5,7 +5,8 @@
          syntax/stx
          syntax/kerncase
          scheme/struct-info
-         scheme/contract/private/helpers
+         unstable/srcloc
+         unstable/location
          (for-syntax scheme/base
                      syntax/kerncase
                      "rep.ss"
@@ -110,9 +111,10 @@
   (pattern x:expr
            #:with c #`(contract #,ctc
                                 x
-                                (quote #,(string->symbol (or (build-src-loc-string #'x) "")))
+                                (quote #,(source-location->string #'x))
-                                (quote #,(or '<this-macro>))
+                                '<this-macro>
-                                (quote-syntax #,(syntax/loc #'x (<there>))))))
+                                #f
+                                (quote-srcloc x))))
 
 ;; Literal sets