From 4e3874a1c5aae1167e7133c86ed1bb82b8285d48 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Sun, 17 Jan 2010 18:50:40 +0000
Subject: [PATCH] Moved path pretty-printing into blame module.

svn: r17707
---
 collects/scheme/contract/private/blame.ss | 22 +++++++++++++++-------
 1 file changed, 15 insertions(+), 7 deletions(-)

diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss
index a9f0899cc5..4b9c5f8640 100644
--- a/collects/scheme/contract/private/blame.ss
+++ b/collects/scheme/contract/private/blame.ss
@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require unstable/srcloc scheme/pretty "helpers.ss")
+(require unstable/srcloc scheme/pretty setup/main-collects)
 
 (provide blame?
          make-blame
@@ -45,13 +45,21 @@
     (current-continuation-marks)
     b)))
 
+(define (simplify-source loc)
+  (let* ([src (srcloc-source loc)])
+    (if (path? src)
+      (let* ([rel (path->main-collects-relative src)])
+        (if (pair? rel)
+          (apply build-path
+                 (bytes->path #"<collects>")
+                 (map bytes->path-element (cdr rel)))
+          rel))
+      src)))
+
 (define (default-blame-format b x custom-message)
-  (let* ([source-message
-          (let* ([loc (blame-source b)])
-            (source-location->prefix
-             (struct-copy
-              srcloc loc
-              [source (source->name (srcloc-source loc))])))]
+  (let* ([source-message (source-location->prefix
+                          (simplify-source
+                           (blame-source b)))]
          [guilty-message (show (blame-guilty b))]
          [contract-message (show (blame-contract b))]
          [value-message (if (blame-value b)