started on a better way to do the obligation coloring

collects/drracket/syncheck.rkt

@@ -2108,6 +2108,30 @@ If the namespace does not, they are colored the unbound color.
         (color-unused requires unused-requires)
         (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
     
+    (define (annotate-contracts stx)
+      (define start-map (make-hash))
+      (define arrow-map (make-hash))
+      (define domain-map (make-hash))
+      (define range-map (make-hash))
+      (define (add-to-map stx prop map)
+        (let loop ([val (syntax-property stx prop)])
+          (cond
+            [(symbol? val)
+             (hash-set! map val (cons stx (hash-ref map val '())))]
+            [(pair? val)
+             (loop (car val))
+             (loop (cdr val))])))
+      
+      (let loop ([stx stx])
+        (add-to-map stx 'racket/contract:contract-on-boundary start-map)
+        (add-to-map stx 'racket/contract:domain-of domain-map)
+        (add-to-map stx 'racket/contract:rng-of range-map)
+        (add-to-map stx 'racket/contract:function-contract arrow-map)
+        (syntax-case stx ()
+          [(a . b) (loop #'a) (loop #'b)]
+          [else (void)])))
+    
+#|
     (define (annotate-contracts stx)
       (let loop ([stx stx])
         (let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
@@ -2141,7 +2165,7 @@ If the namespace does not, they are colored the unbound color.
          (base-color stx polarity)]
         [else
          (color stx unk-obligation-style-name 'contract-mode)])))
-    
+|#
     ;; returns #t if the result is known to be a predicate that shoudl correspond to a
     ;; complete obligation for the contract. If it is some unknown variable, this variable
     ;; may refer to some other contract with nested obligations, so we have to return #f here.

collects/racket/contract/private/arrow.rkt

@@ -350,14 +350,18 @@ v4 todo:
 
 ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
 (define-for-syntax (->/proc/main stx)
-  (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
+  (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)]
+               [(this->) (gensym 'this->)])
     (with-syntax ([(args body) inner-args/body])
       (with-syntax ([(dom-names ...) dom-names]
                     [(rng-names ...) rng-names]
                     [(kwd-names ...) kwd-names]
-                    [(dom-ctcs ...) dom-ctcs]
+                    [(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->)) 
-                    [(rng-ctcs ...) rng-ctcs]
+                                         (syntax->list dom-ctcs))]
-                    [(kwd-ctcs ...) kwd-ctcs]
+                    [(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:rng-of this->))
+                                         (syntax->list rng-ctcs))]
+                    [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
+                                         (syntax->list kwd-ctcs))]
                     [(kwds ...) kwds]
                     [inner-lambda 
                      (maybe-a-method/name
@@ -371,12 +375,15 @@ v4 todo:
                               (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
                               (make-contracted-function inner-lambda ctc)))])
           (values
-           (syntax 
+           (syntax-property 
-            (build--> '->
+            (syntax 
-                      (list dom-ctcs ...) '() #f
+             (build--> '->
-                      (list kwd-ctcs ...) '(kwds ...) '() '()
+                       (list dom-ctcs ...) '() #f
-                      (list rng-ctcs ...) use-any?
+                       (list kwd-ctcs ...) '(kwds ...) '() '()
-                      outer-lambda))
+                       (list rng-ctcs ...) use-any?
+                       outer-lambda))
+            'racket/contract:function-contract 
+            this->)
            inner-args/body
            (syntax (dom-names ... rng-names ...))))))))
   

collects/racket/contract/private/provide.rkt

@@ -663,9 +663,12 @@
             (code-for-one-id/new-name stx id reflect-id ctrct user-rename-id #f #t)]
            [(stx id reflect-id ctrct user-rename-id mangle-for-maker?)
             (code-for-one-id/new-name id reflect-id ctrct user-rename-id mangle-for-maker? #t)]
-           [(stx id reflect-id ctrct user-rename-id mangle-for-maker? provide?)
+           [(stx id reflect-id ctrct/no-prop user-rename-id mangle-for-maker? provide?)
-            (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]
+            (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
-                  [ex-id (or reflect-id id)])
+                  [ex-id (or reflect-id id)]
+                  [ctrct (syntax-property ctrct/no-prop
+                                          'racket/contract:contract-on-boundary
+                                          (gensym 'provide/contract-boundary))])
               (with-syntax ([id-rename ((if mangle-for-maker? 
                                             a:mangle-id-for-maker
                                             a:mangle-id)